Excel VBA script to transfer rows from one worksheet to another based on a certain value

Question

I am a novice when it comes to Excel VBA and Macros. I have a workbook that contains two primary sheets - "DAILY_SHOP_FILE" and "Reconciled", the former serves as an order sheet and the latter serves as an archive sheet for the orders once they have been shipped. I want to write a VBA Script/Macro that transfers an entire row from the DAILY_SHOP_FILE to the Reconciled sheet when a user inputs the value "yes" into the final column. Both sheets will have the same headers in row 1. I found a code on here and modified it slightly to my needs:

Dim keyColumn As Integer
Dim i As Integer
Dim keyWord As Variant 'I've used variant, so you can choose your own data type for the keyword
Dim dataSh As String 'I'm using sheet names for sheet referencing
Dim populateSh As String
Dim rowNum As Integer
Dim dataRow() As Variant

Sub Populate()
'set the column number, which contains the keywords, the keyword itself,
'name of the sheet to populate and the row offset you'd like to start populating
    populateSh = "Reconciled"
    keyColumn = 15
    keyWord = "yes"
    rowNum = 1
    'assuming you run the macro in the sheet you get the data from, get its name to return to it after copying the row
    dataSh = ActiveSheet.Name
'loop through all the used cells in the column
    For i = 1 To ActiveSheet.UsedRange.Rows.Count
        If Cells(i, keyColumn) = keyWord Then
'starting in row 1 in the sheet you populate, you'll have to set the rowNum variable to desired offset few lines above
        rowNum = rowNum + 1
        Call copyRow(i, rowNum)
    End If
 Next i
End Sub

Sub copyRow(ByVal cRow As Integer, ByVal pRow As Integer)
    Dim colNum As Integer
'set the number of columns you'd like to copy
   colNum = 15
'redimension the array to carry the data to other sheet
'this can be done any way you,d like, but I'm using array for flexibility
   ReDim dataRow(1 To colNum)
'put the data into the array, as an example I'm using columns 1-15 while skipping the keyword column.
     dataRow(1) = Cells(cRow, 1)
     dataRow(2) = Cells(cRow, 2)
     dataRow(3) = Cells(cRow, 3)
     dataRow(4) = Cells(cRow, 4)
     dataRow(5) = Cells(cRow, 5)
     dataRow(6) = Cells(cRow, 6)
     dataRow(7) = Cells(cRow, 7)
     dataRow(8) = Cells(cRow, 8)
     dataRow(9) = Cells(cRow, 9)
     dataRow(10) = Cells(cRow, 10)
     dataRow(11) = Cells(cRow, 11)
     dataRow(12) = Cells(cRow, 12)
     dataRow(13) = Cells(cRow, 13)
     dataRow(14) = Cells(cRow, 14)
     dataRow(15) = Cells(cRow, 15)
     Sheets(populateSh).Select
        For p = 1 To UBound(dataRow)
        Cells(pRow, p) = dataRow(p)
        Next p
    Sheets(dataSh).Select
End Sub

It works well but the only problem is it doesn't actually delete the row from the DAILY_SHOP_FILE. How could I solve this? Additionally, it'd be nice to refer to the sheetnames as per the VBA rather than the actual tab names because if a user renamed one of the tabs the code wouldn't work anymore. Thank You!

The only time you will get caught out by the user renaming a sheet would be the spot where you say `populateSh = "Reconciled"`. You can get around that by using `populateSh = ReconciledSheet.Name` (assuming the sheet which currently has a `Name` of `"Reconciled"` has a `CodeName` of `ReconciledSheet` - so just change that bit to whatever code name you actually gave it in the VBE properties window) — YowE3K, Dec 20 '17 at 23:46
Note: I recommend [always to use `Long` instead of `Integer`](https://stackoverflow.com/a/26409520/3219613) especially when dealing with row counts. Excel has more rows than `Integer` can handle. — Pᴇʜ, Dec 21 '17 at 09:50

score 0 · Answer 1 · answered Dec 21 '17 at 00:10

Sub Update_Reconciled()
Application.ScreenUpdating = False

Dim T2()
Set D1 = CreateObject("scripting.dictionary")
Set R1 = Sheet1.UsedRange 'update Sheet1 to match DAILY_SHOP_FILE code name
T1 = R1
a = 1

For i = 2 To UBound(T1)
    If Trim(UCase(T1(i, UBound(T1, 2)))) = "YES" Then
        D1(i) = i
        ReDim Preserve T2(1 To UBound(T1, 2), 1 To a)
        For j = 1 To UBound(T1, 2)
            T2(j, a) = T1(i, j)
        Next j
        a = a + 1
    End If
Next i

If a > 1 Then
    Sheet2.Range("A99999").End(xlUp).Offset(1, 0).Resize(UBound(T2, 2), UBound(T2, 1)) = Application.Transpose(T2) 'update Sheet2 to match Reconciled code name

    cnt = 0
    For Each k In D1.items
        Sheet1.Rows(k - cnt).Delete 'update Sheet1 to match DAILY_SHOP_FILE code name
        cnt = cnt + 1
    Next k
End If

Application.ScreenUpdating = True
End Sub

score 0 · Answer 2 · answered Dec 21 '17 at 00:51

Sorry for not looking at your specific setup, but here is a generic solution that should work fine for you, with just a bit of customization. This is general enough to help others as well.

Sub NewSheetData()

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

Dim Rng As Range

Set Rng = Range([A1], Range("A" & Rows.Count).End(xlUp))

On Error Resume Next
    With Rng
        .AutoFilter , field:=1, Criteria1:="network", Operator:=xlOr, Criteria2:="telcom"
        .SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Sheet2").Range("A1")
        .AutoFilter
    End With
On Error GoTo 0

Application.EnableEvents = True

End Sub

Excel VBA script to transfer rows from one worksheet to another based on a certain value

2 Answers2