用作翻译的二维数组复制和粘贴行

我有一个电子表格，调出代理分配的工作。 “代理ID”在列A中，数据在列AM中。

我为每位代理的主pipe（主pipe姓氏）分别填写单。 我很难将代理ID编码到macros中，但是我想使它工作，以便我可以从翻译表中提取数据，翻译表只能包含代理ID和相应的主pipe姓。 我不知道如何逐行parsing数据，find代理ID，然后将该行复制到相应的工作表。

我已经有了AgentID，Supervisor的翻译单（名为sup-agent_Trans） 就是这两列。

这是我到目前为止：

Dim varList As Variant Dim lstRowTrans As Long Dim lstRowRework As Long Dim rngArr As Range Dim rngRwk As Range Dim row As Range Dim cell As Range Application.ScreenUpdating = False lstRowTrans = Worksheets("Tech-Sup_Trans").Cells(Rows.Count, "A").End(xlUp).row lstRowRework = Worksheets("Rework").Cells(Rows.Count, "A").End(xlUp).row varList = Sheets("Tech-Sup_Trans").Range("A1:B" & lstRowTrans) Set rngRwk = Sheets("Rework").Range("A1:A" & lstRowRework) For Each cell In rngRwk For i = LBound(varList, 2) To UBound(varList, 2) 'columns If i = cell(i).Value <> "" Then For j = LBound(varList, 1) To UBound(varList, 1) 'rows If varList(j, cell(i).Value) Then IsInArray = True End If Next j End If Next i Next cell 

Answer 1

所以在有人如此高贵地指出我不需要使用数组的时候，我使用了“查找”函数来计算范围。 感谢findwindow！

 Dim shtRwk As Worksheet Dim shtRef As Worksheet Dim DestCell As Range Dim rngRwk As Range Dim lstRowTrans As Long Dim lstRowRework As Long Dim rngArr As Range Dim row As Range Dim cell As Range Dim strSup As String Set shtRwk = Sheets("Rework") Set shtRef = Sheets("Tech-Sup_Trans") Application.ScreenUpdating = False lstRowTrans = shtRef.Cells(Rows.Count, "A").End(xlUp).row lstRowRework = shtRwk.Cells(Rows.Count, "A").End(xlUp).row Set rngRwk = Sheets("Rework").Range("A2:A" & lstRowRework) For Each cell In rngRwk With shtRef.Range("A1:B" & lstRowTrans) Set DestCell = .Find(What:=cell.Value, _ After:=.Cells(.Cells.Count), _ LookIn:=xlValues, _ LookAt:=xlWhole, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False) If Not DestCell Is Nothing Then strSup = DestCell.Offset(0, 1).Value cell.EntireRow.Copy Sheets(strSup).Select ActiveSheet.Range("A65536").End(xlUp).Select Selection.Offset(1, 0).Select ActiveSheet.Paste shtRwk.Select Else MsgBox "No Sup found for tech " & cell.Value End If End With Next cell Application.ScreenUpdating = True