Search column for non-blank cell then, if successful, create new worksheet, copy row to it and delete it from first sheet

[Euler271]

Hello,

I'm working in Access VBA trying to manipulate about 50 Excel workbooks. I need code to search a column for any non-blank cell, copy the entire row, create a new worksheet, paste the copied row to it (with headers from first sheet) then delete the row in the first worksheet. I then need it to continue searching the same column for non-blank cells and copy/paste/delete those rows to the new worksheet. Furthermore, it needs to check a second column in the first worksheet for any non-blank cell and do the same thing.

I tried using AutoFilter but I've encountered a problem when trying to count the number of visible rows. (The second worksheet should not be created if no non-blank cells are found in either of the two columns.)

I'm sure this isn't a difficult problem for someone better at Excel VBA than I. (I'm much better with Access VBA.)

Thanks a lot for any help.

 

[sijpie]

This will do the trick. I am using arrays to speed up in case the tables are large

Check the comments: where they start with <<<< your input is required

Option Explicit

Sub TransferData()
    Dim wsWS1 As Worksheet, wsWS2 As Worksheet
    Dim vOut As Variant, vIn As Variant
    Dim rIn As Range
    Dim lRi As Long, lRo As Long, lStart As Long, UB1 As Long, UB2 As Long, _
        lC1 As Long, lC2 As Long, lCnt As Long, lCi As Long
    Dim bHeader As Boolean
    Dim colRows As Collection
   
    bHeader = True '<<<<set to false if input range does not have header
    lStart = IIf(bHeader, 2, 1)
   
    Set wsWS1 = Sheets("Sheet1") '<<<< modify input sheetname as required
   
    Set rIn = wsWS1.Range("A1").CurrentRegion
    vIn = rIn.Value
    'get row and column count
    UB1 = UBound(vIn, 1): UB2 = UBound(vIn, 2)
   
    'create the collection to hold which rows are to be removed
    Set colRows = New Collection
   
    '<<< Assuming 1st column is B (2) and 2nd column is E (5), modify as required
    lC1 = 2
    lC2 = 5
   
    'Count the number of rows in the two columns that havea value, so the output array can be dimensioned
    For lRi = lStart To UB1
        If Not IsEmpty(vIn(lRi, lC1)) Or Not IsEmpty(vIn(lRi, lC2)) Then
            lCnt = lCnt + 1
            colRows.Add lRi
        End If
    Next lRi
    ReDim vOut(1 To lCnt + lStart - 1, 1 To UB2)
       
    'if header copy header row
    lRo = 1
    If bHeader Then
        For lCi = 1 To UB2
            vOut(1, lCi) = vIn(1, lCi)
        Next lCi
        lRo = lRo + 1
    End If
   
    For lC1 = 1 To colRows.Count
        lRi = colRows(lC1)
        'copy the rows from input to output array
        For lCi = 1 To UB2
            vOut(lRo, lCi) = vIn(lRi, lCi)
        Next lCi
        lRo = lRo + 1
    Next lC1
       
    For lC1 = colRows.Count To 1 Step -1    'do in reverse as we are deleting from the bottom up
        lRi = colRows(lC1)
         'delete the row from sheet input
        wsWS1.Rows(lRi).EntireRow.Delete
    Next lC1
     
    ' and output the result to a new sheet
   
    Sheets.Add after:=wsWS1
    Set wsWS2 = ActiveSheet
    wsWS2.Range("A1").Resize(UBound(vOut, 1), UB2).Value = vOut
   
    'Clean up
    Set colRows = Nothing
    Set wsWS1 = Nothing
    Set wsWS2 = Nothing
    Set rIn = Nothing
End Sub

 

[Euler271]

Wow, this is perfect. Thanks so much for spending your time on this. The code looks very elegant. I'll try it right away.