基于一个单元格值复制行并引用另一个单元格值并粘贴到新工作表上

Question

我必须创建一个报告，在其中我获取带有事务列表的原始数据，我需要我的宏根据C列中的项目组合名称将每个事务发送到其各自的表单

我这样做了，但现在我需要从下面给出的参考表中的“现金”下的诺基亚交易，粘贴在“诺基亚 - 现金”表下

有人可以帮我构建我的代码的第二部分，这有助于移动if C = Nokia和J = Semi Paid然后转移到Nokia - Cash？

Answer 1

这与我之前回答的问题类似。

您不必担心创建工作表并命名它们，代码会处理它。它还会跳过参考表中没有的项目。

它将描述项与参考表中的项匹配，然后将卡名与匹配项的类别名称<< / em>以命名相关表格。如果此工作表不存在，则会创建并传递行数据，否则只需传递行数据。

Sub MyClients()
Dim lastrow As Long, lastcol As Long, matchrow As Long, i As Long, j As Long
Dim wsname As String
lastrow = Worksheets("Raw").Cells(Worksheets("Raw").Rows.Count, 1).End(xlUp).Row
lastcol = Worksheets("Raw").Cells(1, Worksheets("Raw").Columns.Count).End(xlToLeft).Column

Application.ScreenUpdating = False
For i = 2 To lastrow
    On Error Resume Next
    matchrow = Application.WorksheetFunction.Match(Worksheets("Raw").Cells(i, 10).Value, Worksheets("Reference").Range("A:A"), 0)
    If Err.Number = 1004 Then
        MsgBox "Couldn't find item: '" & Worksheets("Raw").Cells(i, 10).Value & "' within reference sheet. Skipping row no: " & i
        GoTo skip:
    End If
    wsname = Worksheets("Raw").Cells(i, 3).Value & " - " & Worksheets("Reference").Cells(matchrow, 2).Value
    On Error Resume Next
    Worksheets(wsname).Cells(Worksheets(wsname).Rows.Count, 1).End(xlUp).Offset(1, 0) = Worksheets("Raw").Cells(i, 1).Value
    For j = 1 To lastcol - 1
        Worksheets(wsname).Cells(Worksheets(wsname).Rows.Count, 1).End(xlUp).Offset(0, j) = Worksheets("Raw").Cells(i, j).Value
    Next j
    If Err.Number = 9 Then
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsname
        For j = 1 To lastcol
            Worksheets(wsname).Cells(1, j) = Worksheets("Raw").Cells(1, j).Value
        Next j
        Worksheets(wsname).Cells(Worksheets(wsname).Rows.Count, 1).End(xlUp).Offset(1, 0) = Worksheets("Raw").Cells(i, 1).Value
        For j = 1 To lastcol - 1
            Worksheets(wsname).Cells(Worksheets(wsname).Rows.Count, 1).End(xlUp).Offset(0, j) = Worksheets("Raw").Cells(i, j).Value
        Next j
    End If
skip:
Next i
Worksheets("Raw").Activate
Application.ScreenUpdating = True
End Sub