1

I have a large workbook with many products, including specs, pricing and assorted calculation. When a product expires I'd like to move it to a EOL-sheet so I keep a log of old products.

This script should look at the selected rows, move the content to sheet "EOL", delete it from the original sheet, and skip all hidden rows.
It works if I select one cell, however if I select more cells, it doesn't correctly iterate through the full range.

Sub MoveRows()
    Call SpeedUp
    Dim SourceSheet As Worksheet
    Dim TargetSheet As Worksheet
    Dim LastRow As Long
    Dim rng As Range
            
    Set rng = Selection
    
    Set SouceSheet = ActiveSheet
    Set TargetSheet = ActiveWorkbook.Sheets("EOL")

    TargetRow = ActiveCell.row
    LastRow = TargetSheet.Cells(TargetSheet.Rows.Count, "D").End(xlUp).row + 1
     
    For Each row In rng.Rows
        If row.Rows.Hidden Then
            TargetRow = TargetRow + 1
        
        Else
            ActiveSheet.Rows(TargetRow).Copy
            TargetSheet.Rows(LastRow).PasteSpecial xlPasteFormulasAndNumberFormats
            TargetSheet.Rows(LastRow).PasteSpecial xlPasteFormats
            Rows(TargetRow).EntireRow.Delete
            LastRow = LastRow + 1
        End If
             
    Next row
        
    Call SpeedDown
      
End Sub

Note: the SpeedUp/SpeedDown function is to turn off screnupdating etc. for efficiency. Doesn't affect the script itself.

As I tested it commenting out the delete function, it copied the first cell repeatedly, obviously since TargetRow didn't change.
When I added TargetRow = TargetRow + 1 after the End If it works.
When I uncomment the delete part, it doesn't work as I would expect.
As TargetRow is deleted, then I would think that the next row would be the new TargetRow, but it seems this doesn't happen.

I guess my problem is that there is no direct link between TargetRow and the iteration of rng.Rows.
How can I solve this? Is there a way to store all the moved rows in a list and subsequently delete them through a new iteration? Or maybe that is a bit too "python-thinking" for VBA?

Community
  • 1
  • 1
Are
  • 9
  • 4

3 Answers3

1

Move Visible Rows of the Selection

  • BTW, if you would have used Option Explicit, it would have warned you about the undeclared variable row and the typo in Set SouceSheet = ActiveSheet.
  • The Row property usually uses the capital letter R. In your code, there are occurrences of .row because you are using a variable named row. To make the case of the property capital again, declare Dim Row As Range. Then you could use another variable name instead of Row e.g. rrg (Row Range), srrg...
Option Explicit

Sub MoveRows()
    
    If Selection Is Nothing Then Exit Sub ' no visible workbooks open
    If Not TypeOf Selection Is Range Then Exit Sub ' not a range
    
    Dim sws As Worksheet: Set sws = Selection.Worksheet
    
    Dim srg As Range: Set srg = Intersect(Selection.EntireRow, sws.UsedRange)
    If srg Is Nothing Then Exit Sub ' not in rows of the used range
    
    Dim svrg As Range
    On Error Resume Next
        Set svrg = srg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If svrg Is Nothing Then Exit Sub ' no visible cells
    
    Dim dws As Worksheet
    On Error Resume Next
        Set dws = sws.Parent.Sheets("EOL")
    On Error GoTo 0
    If dws Is Nothing Then Exit Sub ' worksheet 'EOL' doesn't exist
    
    Dim dfcell As Range
    With dws.UsedRange
        Set dfcell = dws.Cells(.Row + .Rows.Count, "A")
    End With
    
    Application.ScreenUpdating = False
    
    svrg.Copy
    dfcell.PasteSpecial xlPasteFormulasAndNumberFormats
    dfcell.PasteSpecial xlPasteFormats
        
    svrg.Delete xlShiftUp
      
    Application.ScreenUpdating = True

    MsgBox "Rows moved.", vbInformation
      
End Sub
VBasic2008
  • 44,888
  • 5
  • 17
  • 28
  • This is very close to what I need! Only issue left is that I get a Runtime 1004 "This won't work because it would move cells in a table on your worksheet." on the delete command. I'm guessing it is due to it being an array and not full rows? - My bad for the typo there, been rewriting so many times.. And as for Row, I thought only Rows were a property where as "row" can be used freely. – Are Dec 30 '22 at 01:20
0

You're use a For Each, but you hardly ever use row except for when you want to check if it's hidden. Why do you need TargetRow at all? Try:

For Each row In rng.Rows
    If Not row.Rows.Hidden Then
        row.Copy
        TargetSheet.Rows(LastRow).PasteSpecial xlPasteFormulasAndNumberFormats
        TargetSheet.Rows(LastRow).PasteSpecial xlPasteFormats
        row.EntireRow.Delete
        LastRow = LastRow + 1
    End If    
Next row
dwirony
  • 5,487
  • 3
  • 21
  • 43
  • I did try to find a way to use "row", however this gives the same problem as the TargetRow, it is skipping rows when deleting rows :( – Are Dec 30 '22 at 01:09
  • @Are Ah, naturally whenever you're deleting rows you should loop backwards - from the bottom up. – dwirony Jan 04 '23 at 16:17
  • Exactly what I was missing :) – Are Jan 04 '23 at 18:11
-1
  • UPDATE *

So after lots of time spent I did finally get to a solution which does the trick.

Sub MoveRows()
   
    Dim SourceSheet As Worksheet
    Dim TargetSheet As Worksheet
    Dim rng As Range
    Dim TargetRow As Integer
    Dim StartRow As Integer
    Dim EndRow As Integer
    Dim LastRow As Long
     
    Set rng = Selection
    Set SourceSheet = ActiveSheet
    Set TargetSheet = ActiveWorkbook.Sheets("EOL")
    
    LastRow = TargetSheet.Cells(TargetSheet.Rows.Count, "D").End(xlUp).row + 1
    StartRow = rng.row
    EndRow = rng.Rows.Count + StartRow - 1
        
    For i = EndRow To StartRow Step -1
        If Not Rows(i).Hidden Then
            ActiveSheet.Rows(i).Copy
            TargetSheet.Rows(LastRow).PasteSpecial xlPasteFormulasAndNumberFormats
            TargetSheet.Rows(LastRow).PasteSpecial xlPasteFormats
            Rows(i).EntireRow.Delete
            LastRow = LastRow + 1
         End If
    Next i

    Cells(EndRow, 1).Select

End Sub

Thanks to all for the help!

Are
  • 9
  • 4