I have been an Excel-user for decades by now, VBA has been "out there" but nothing I've spent much time on in the past. Only minor alterations on existing scripts etc. However I wanted to increase my knowledge and after about a month of tutorials, googling and more googling I feel that I'm getting a slight grip on the case.

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

Currently, this script is as far as I have come. It should look at the selected rows, and move the content to sheet "EOL" and delete it from the original sheet, and skip all hidden rows. It works well 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 of 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 flawlessly. However, 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 like this doesn't happen.

I guess my problem is that there is no direct link between TargetRow and the iteration of rng.Rows, but 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 .. ?

Appreciate all input on this probably fairly newbie question :)

CodePudding user response：

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

CodePudding user response：

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