Snasui Excel Forum

Code: Select all

Sub test()

    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim lastRow As Long
    Dim targetRow As Long
    Dim col As String
    
    ' Create a new worksheet for the target
    Set wsTarget = Worksheets.Add
    wsTarget.Name = "TargetSheet"

    ' Specify the column to check (e.g., "A" for column A)
    col = "i"

    ' Initialize the target row
    targetRow = 1

    For Each wsSource In Worksheets
        If wsSource.Name <> "TargetSheet" Then
            ' Set the source worksheet
        '    Set wsSource = ActiveSheet
        
            ' Loop through each row from the bottom up
            lastRow = wsSource.Cells(wsSource.Rows.Count, col).End(xlUp).Row
            For i = lastRow To 1 Step -1
                Set cell = wsSource.Cells(i, col)
        
                ' Check if the cell in the specified column is not empty
                If cell.Value <> "" Then
                    ' Copy the row to the target sheet
                    wsSource.Rows(i).Copy Destination:=wsTarget.Rows(targetRow)
                    ' Delete the row from the source sheet
                    wsSource.Rows(i).EntireRow.Delete
                    ' Move to the next row in the target sheet
                    targetRow = targetRow + 1
                End If
            Next i
        End If
    Next wsSource
End Sub

Code: Select all

Sub test()

Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim lastRow As Long
    Dim targetRow As Long
    Dim col As String

    ' Set the source worksheet
    Set wsSource = ActiveSheet

    ' Create a new worksheet for the target
    Set wsTarget = Worksheets.Add
    wsTarget.Name = "TargetSheet"

    ' Specify the column to check (e.g., "A" for column A)
    col = "i"

    ' Initialize the target row
    targetRow = 1

    ' Loop through each row from the bottom up
    lastRow = wsSource.Cells(wsSource.Rows.Count, col).End(xlUp).Row
    For i = lastRow To 1 Step -1
        Set cell = wsSource.Cells(i, col)

        ' Check if the cell in the specified column is not empty
        If cell.Value <> "" Then
            ' Copy the row to the target sheet
            wsSource.Rows(i).Copy Destination:=wsTarget.Rows(targetRow)
            ' Delete the row from the source sheet
            wsSource.Rows(i).EntireRow.Delete
            ' Move to the next row in the target sheet
            targetRow = targetRow + 1
        End If
    Next i
End Sub