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

根据单元格值将行移动到现有/新工作表

1 个答案: