根據單元格值將行移動到現有的/新的工作表中

Question

我需要的是相當簡單的，但我不能爲我的生活找出如何在代碼中編寫此代碼。我試圖尋找一個可以做到這一點的宏，但到目前爲止沒有運氣。

我有一個工作表，其中包含一個工作表，其中包含原始數據和30個左右的工作表爲不同的客戶。原始數據工作表中的每一行都有第一列中客戶的名稱。

我需要製作一個宏，將每行剪切並粘貼到相應客戶的工作表中，例如，如果I2 = CustomerA，行排列到表CustomerA的末尾。此外，有些客戶還沒有工作表，因爲它們是新的，所以例如，如果I5 = CustomerZ但未找到工作表CustomerZ，則創建它，然後移動該行。

Answer 1

你真正需要做的是設置你：
sh33tName，使其符合你的主人工作
custNameColumn因此它與客戶的名字
stRow排在其客戶名單開始

Option Explicit 

Sub Fr33M4cro() 

    Dim sh33tName As String 
    Dim custNameColumn As String 
    Dim i As Long 
    Dim stRow As Long 
    Dim customer As String 
    Dim ws As Worksheet 
    Dim sheetExist As Boolean 
    Dim sh As Worksheet 

    sh33tName = "Sheet1" 
    custNameColumn = "I" 
    stRow = 2 

    Set sh = Sheets(sh33tName) 

    For i = stRow To sh.Range(custNameColumn & Rows.Count).End(xlUp).Row 
     customer = sh.Range(custNameColumn & i).Value 
     For Each ws In ThisWorkbook.Sheets 
      If StrComp(ws.Name, customer, vbTextCompare) = 0 Then 
       sheetExist = True 
       Exit For 
      End If 
     Next 
     If sheetExist Then 
      CopyRow i, sh, ws, custNameColumn 
     Else 
      InsertSheet customer 
      Set ws = Sheets(Worksheets.Count) 
      CopyRow i, sh, ws, custNameColumn 
     End If 
     Reset sheetExist 
    Next i 

End Sub 

Private Sub CopyRow(i As Long, ByRef sh As Worksheet, ByRef ws As Worksheet, custNameColumn As String) 
    Dim wsRow As Long 
    wsRow = ws.Range(custNameColumn & Rows.Count).End(xlUp).Row + 1 
    sh.Rows(i & ":" & i).Copy 
    ws.Rows(wsRow & ":" & wsRow).PasteSpecial _ 
    Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
    Application.CutCopyMode = False 
End Sub 

Private Sub Reset(ByRef x As Boolean) 
    x = False 
End Sub 

Private Sub InsertSheet(shName As String) 
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = shName 
End Sub 

您的列名匹配