基於一個單元格值並參照另一個單元格值複製行並粘貼到新工作表上

Question

我必須創建一個報告，其中包含事務列表的原始數據，我需要我的宏將每個事務發送到其各自的基礎上，如果投資組合名稱在C列

我試過這樣做，但現在我需要從下面給出的參考表中的'現金'下的諾基亞交易，粘貼在表「諾基亞 - 現金」

有人可以幫助我建立我的代碼的第二部分，這有助於移動如果C =諾基亞和J =半支付然後移動到諾基亞 - 現金？

Answer 1

它與我已回答的上一個問題類似。

您不必擔心創建工作表並命名它們，代碼會處理它。它也會跳過參考表中找不到的項目。

它與項匹配說明項目參考表，然後以命名相關表concats 卡名稱與匹配項目的類別名稱。如果此表不存在，它將創建並傳遞行數據，否則只需傳遞行數據。

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