Excel VBA脚本，用于根据特定值将行从一个工作表传输到另一个工作表

Question

对于Excel VBA和Macros，我是一个新手。我有一个包含两个主要工作表的工作簿 - “DAILY_SHOP_FILE”和“Reconciled”，前者用作订单，后者用作订单一旦发货后的存档表。我想编写一个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