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

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