使用VBA在Excel中根据单元格值将数据拆分为多个工作簿

Question

使用VBA在Excel中根据单元格值将数据拆分为多个工作簿

6

每个月我会收到一份销售报告，其中包括我们销售的商品数量和产品详细信息。我使用vba创建了一个模板，用户可以指定一个产品并为其创建一个Excel报告。

然而，我想扩展/修改，如果我有多个Excel报告，而不仅仅是一个报告。我希望Excel将我输入或列出的任意数量的产品代码分离开来。

现在，我在我的模板中添加了一个名为“列表”的选项卡，在其中我可以列出应从中读取vba的产品代码数量（4位数字，在A列中），但我需要帮助修改代码，以便它不再询问用户，而是直接从列表中读取。其次，由于主文件包含所有产品，而我可能只需要其中的20或30个，因此我需要vba代码尽可能灵活。

我设置的方式是，基本上是从主文件更新/复制新信息到月度模板，并将月度模板重新保存为产品代码产品截至2017年9月1日的文件。

Sub monthly()


Dim x1 As Workbook, y1 As Workbook
Dim ws1, ws2 As Worksheet
Dim LR3, LR5 As Long
Dim ws3 As Worksheet
Dim Rng3, Rng4 As Range
Dim x3 As Long

Set x1 = Workbooks("Master.xlsx")
Set y1 = Workbooks("Monthly Template.xlsm")

Set ws1 = x1.Sheets("Products")
Set ws2 = y1.Sheets("Products")
Set ws3 = y1.Sheets("List")

ws2.Range("A3:AA30000").ClearContents
ws1.Cells.Copy ws2.Cells

x1.Close True

LR5 = ws3.Cells(Rows.Count, "A").End(xlUp).Row

With y1.Sheets("List")
Range("A1:A32").Sort key1:=Range("A1"), Order1:=xlAscending
End With





LR3 = ws2.Cells(Rows.Count, "A").End(xlUp).Row


Set Rng3 = ws2.Range("AC3:AC" & LR3)

Set Rng4 = ws3.Range("A1:A" & LR5)

For n = 3 To LR3
ws2.Cells(n, 29).FormulaR1C1 = "=LEFT(RC[-21], 4)"
Next n



With y1.Sheets("List")
    j = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
With ws2
    l = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
For i = 1 To j
    For k = 3 To l
        If Sheets("List").Cells(i, 1).Value = Sheets("Products").Cells(k, 29).Value Then
            With Sheets("Output")
                m = .Cells(.Rows.Count, 1).End(xlUp).Row
            End With
            Sheets("Output").Rows(m + 1).Value = Sheets("Products").Rows(k).Value
        End If
    Next k
Next i

Sheets("Output").Columns("AC").ClearContents


   Dim cell As Range
    Dim dict As Object, vKey As Variant
    Dim Key As String
    Dim SheetsInNewWorkbook As Long
    Dim DateOf As Date


    DateOf = DateSerial(Year(Date), Month(Date), 1)

    With Application
        .ScreenUpdating = False
        SheetsInNewWorkbook = .SheetsInNewWorkbook
        .SheetsInNewWorkbook = 1
    End With

    Set dict = CreateObject("Scripting.Dictionary")
    With ThisWorkbook.Worksheets("List")
        For Each cell In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
            Key = Left(cell.Value, 4)
            'Store an ArrayList in the Scripting.Dictionary that can be retrieved using the Product Key
            If Not dict.exists(Key) Then dict.Add Key, CreateObject("System.Collections.ArrayList")
        Next
    End With

    With Workbooks("Monthly Template.xlsm").Worksheets("Output")
        For Each cell In .Range("H2", .Range("A" & .Rows.Count).End(xlUp))
            Key = Left(cell.Value, 4)
            'Add the Products to the ArrayList in the Scripting.Dictionary that is associated with the Product Key
            If dict.exists(Key) Then dict(Key).Add cell.Value
        Next
    End With

    For Each vKey In dict
        If dict(vKey).Count > 0 Then
            With Workbooks.Add
                With .Worksheets(1)
                    .Name = "Products"
                   ' .Range("A1").Value = "Products"

                    Workbooks("Monthly Template.xlsm").Worksheets("Output").Cells.Copy Worksheets(1).Cells

                      For Z = 1 To LR5
                      For x3 = Rng3.Rows.Count To 1 Step -1
                        If InStr(1, Rng3.Cells(x3, 1).Text, Workbooks("Monthly Template.xlsm").Worksheets("List").Cells(Z, 1).Text) = 0 Then
                            Rng3.Cells(x3, 1).EntireRow.Delete
                        End If
                        Next x3
                        Next Z


                    '.Range("A2").Resize(dict(vKey).Count).Value = Application.Transpose(dict(vKey).ToArray)
                End With
                .SaveAs Filename:=getMonthlyFileName(DateOf, CStr(vKey)), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                .Close SaveChanges:=False
            End With
        End If
    Next

    With Application
        .ScreenUpdating = True
        .SheetsInNewWorkbook = SheetsInNewWorkbook
    End With

End Sub

Function getMonthlyFileName(DateOf As Date, Product As String) As String
    Dim path As String

    path = ThisWorkbook.path & "\Product Reports\"

    If Len(Dir(path, vbDirectory)) = 0 Then MkDir path

    path = path & Format(DateOf, "yyyy") & "\"

    If Len(Dir(path, vbDirectory)) = 0 Then MkDir path

    path = path & Format(DateOf, "mmm") & "\"

    If Len(Dir(path, vbDirectory)) = 0 Then MkDir path

    getMonthlyFileName = path & "Product - " & Product & Format(DateOf, " mmm.dd.yyyy") & ".xlsx"
End Function

- sc1324

3个回答

4

尝试使用两个循环来实现此操作，确保在主列表中按产品进行排序，以使此过程更快。

Dim i as Long, j as Long, k as Long, l as Long, m as Long
With Sheets("List")
    j = .Cells( .Rows.Count, 1).End(xlUp).Row
End With
With Sheets("Products")
    l = .Cells( .Rows.Count, 1).End(xlUp).Row
End With
For i = 2 to j
    For k = 2 to l
        If Sheets("List").Cells(i,1).Value = Sheets("Products").Cells(k,1).Value Then
            With Sheets("Output")
                m = .Cells( .Rows.Count, 1).End(xlUp).Row
            End With
            Sheets("Output").Rows(m+1).Value = Sheets("Products").Rows(k).Value
        End If
    Next k
Next i

编辑

尝试逐步提供一些东西，至少给出一个将结果拆分为不同表格页的方法，而不是只有一个输出表格页（这不会被测试，只是随意编码）：

Dim i as Long, j as Long, k as Long, l as Long, m as Long, n as String
With Sheets("List")
    j = .Cells( .Rows.Count, 1).End(xlUp).Row
End With
With Sheets("Products")
    l = .Cells( .Rows.Count, 1).End(xlUp).Row
End With
For i = 2 to j
    n = Sheets("List").Cells(i,1).Value
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = n
    Sheets(n).Cells(1,1).Value = n
    Sheets(n).Rows(2).Value = Sheets("Products").Rows(1).Value
    For k = 2 to l
        With Sheets(n)
            If .Cells(1,1).Value = Sheets("Products").Cells(k,1).Value Then
            m = .Cells( .Rows.Count, 1).End(xlUp).Row
            .Rows(m+1).Value = Sheets("Products").Rows(k).Value
        End If
    Next k
Next i

- Cyril

我没有检查你的输出位置，所以我只使用了Sheets("Output")。请确保在Columns(1)/Columns("A")中有一个标题，因为这会给“m”一个起点。假设Sheets("List")是用户输入其产品编号列表的地方，而Sheets("Products")是主列表。 - Cyril

1

@sc1324 所以在这种情况下，每个 Sheets("Output") 的实例都会变成 *Sheets("Monthly Template")*，是吗？ - Cyril

@sc1324 现在，这段代码是独立的，假设每个工作表都在同一个工作簿中。你需要将它放在包含人们正在填写列表的工作簿中（使用Sheets("List")，很可能与“GO”按钮相关联，在那里运行此代码）。由于您似乎正在使用不同的工作簿，因此您需要调整此代码中的对象（对象为Workbook.Sheet.Range）。 - Cyril

我修改了我的问题，希望这有助于澄清我需要实现的内容 @ Cyril - sc1324

1

@sc1324 公平地说，你最初的问题已经得到了回答；更合适的做法是先应用这个解决方案，然后再提出关于分离的另一个问题，特别是因为这需要更多的工作。将每个唯一值放在自己的工作表中，然后为每个工作表运行一个循环，将是最直接的方法；然后你就可以将一个工作表移动到一个新的工作簿中。 - Cyril

显示剩余2条评论

1

我不知道为什么有些人在写VBA代码时会认为在一千行代码之前声明所有变量并使用奇怪的名称是个好主意……

无论如何，回到问题上来，我相信你想要实现的是：

1）指定一个列表，当代码遍历该列表并根据列出的项目筛选数据时。 2）创建一个工作簿，将筛选后的数据复制到其中。 3）将工作簿保存到您指定的位置，并赋予特定的名称。

因此，您的程序访问点应该是遍历指定列表的主函数。

然后，在主函数内部，您将拥有一个处理产品ID的子程序，然后在产品ID上进行筛选，然后将数据复制到新创建的工作簿中。

最后一步是给新工作簿命名并保存它。

因此，以下是一些代码框架，希望能帮助您创建月度报告。您需要自己编写如何将数据从主工作簿复制到目标工作簿的代码（这应该很简单，只需对源列表进行筛选并将结果复制到目标工作簿即可，无需使用字典或数组列表）。

Sub main()
    Dim rngIdx As Range
    Set rngIdx = ThisWorkbook.Sheets("where your list is").Range("A1")

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    While (rngIdx.Value <> "")
        Call create_report(rngIdx.Value)
        Set rngIdx = rngIdx.Offset(1, 0)
    Wend

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

Sub create_report(ByVal product_ID As String)
    Dim dest_wbk As Workbook
    Set dest_wbk = Workbooks.Add

    Call do_whatever(ThisWorkbook, dest_wbk, product_ID)

    dest_wbk.SaveAs getMonthlyFileName(some_date, product_ID)
    dest_wbk.Close

End Sub

Sub do_whatever(source_wbk As Workbook, dest_wbk As Workbook, ByVal product_ID As String)
    ' this is the code where you copy from your master data to the destination workbook
    ' modify sheet names, formatting.......etc.
End Sub

- Luan Yi

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- user6432984 · Accepted Answer

我看不出为什么要保存Monthly Template.xlsm的副本。OP的代码只是在工作表上创建一个列表，然后将其保存到文件中。可能会缺少一些格式，这些格式通常会从主文件中保存下来。 getMonthlyFileName(DateOf, Product) - 创建一个文件路径（根路径\日期年份\日期月份\产品 - 产品mmm.dd.yyyy.xlsx）。以这种方式，可以将产品文件存储在易于查找的结构中。

Sub CreateMonthlyReports()
    Dim cell As Range
    Dim dict As Object, vKey As Variant
    Dim Key As String
    Dim SheetsInNewWorkbook As Long
    Dim DateOf As Date

    DateOf = DateSerial(Year(Date), Month(Date), 1)

    With Application
        .ScreenUpdating = False
        SheetsInNewWorkbook = .SheetsInNewWorkbook
        .SheetsInNewWorkbook = 1
    End With

    Set dict = CreateObject("Scripting.Dictionary")
    With ThisWorkbook.Worksheets("List")
        For Each cell In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
            Key = Left(cell.Value, 4)
            'Store an ArrayList in the Scripting.Dictionary that can be retrieved using the Product Key
            If Not dict.exists(Key) Then dict.Add Key, CreateObject("System.Collections.ArrayList")
        Next
    End With

    With Workbooks("Master.xlsx").Worksheets("Products")
        For Each cell In .Range("H2", .Range("H" & .Rows.Count).End(xlUp))
            Key = Left(cell.Value, 4)
            'Add the Products to the ArrayList in the Scripting.Dictionary that is associated with the Product Key
            If dict.exists(Key) Then dict(Key).Add cell.Value
        Next
    End With

    For Each vKey In dict
        If dict(vKey).Count > 0 Then
            With Workbooks.Add
                With .Worksheets(1)
                    .Name = "Products"
                    .Range("A1").Value = "Products"
                    .Range("A2").Resize(dict(vKey).Count).Value = Application.Transpose(dict(vKey).ToArray)
                End With
                .SaveAs FileName:=getMonthlyFileName(DateOf, CStr(vKey)), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                .Close SaveChanges:=False
            End With
        End If
    Next

    With Application
        .ScreenUpdating = True
        .SheetsInNewWorkbook = SheetsInNewWorkbook
    End With

End Sub

Function getMonthlyFileName(DateOf As Date, Product As String) As String
    Dim path As String

    path = ThisWorkbook.path & "\Product Reports\"

    If Len(Dir(path, vbDirectory)) = 0 Then MkDir path

    path = path & Format(DateOf, "yyyy") & "\"

    If Len(Dir(path, vbDirectory)) = 0 Then MkDir path

    path = path & Format(DateOf, "mmm") & "\"

    If Len(Dir(path, vbDirectory)) = 0 Then MkDir path

    getMonthlyFileName = path & "Product - " & Product & Format(DateOf, " mmm.dd.yyyy") & ".xlsx"
End Function