Excel VBA脚本根据某个值将行从一个工作表传输到另一个工作表

Question

我是 Excel VBA 和宏的新手。我有一个包含两个主要工作表的工作簿 - “DAILY_SHOP_FILE”和“已对帐”，前者用作订单表，后者用作订单发货后的存档表。我想编写一个 VBA 脚本/宏，当用户在最后一列中输入值“yes”时，它将整行从 DAILY_SHOP_FILE 传输到 Reconciled 表。两张表在第 1 行中都有相同的标题。我在这里找到了一个代码，并根据我的需要对其进行了一些修改：

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

它运行良好，但唯一的问题是它实际上并没有从 DAILY_SHOP_FILE 中删除该行。我怎么能解决这个问题？此外，最好根据 VBA 引用工作表名称而不是实际的选项卡名称，因为如果用户重命名其中一个选项卡，则代码将不再工作。谢谢！

Answer 1

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

Answer 2

很抱歉没有查看您的具体设置，但这里有一个通用的解决方案，应该适合您，只需进行一些自定义。这也足以帮助其他人。

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