Question

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

但是，如果我有多个Excel报告而不是一个报告，我想扩展/修改。我想excel分开我输入或列出的许多产品代码。

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

我设置的方式，基本上是将主信息中的新信息更新/复制到每月模板中，并将每月模板重新保存为9.1.2017文件中的产品代码产品。

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

Answer 1

我认为没有理由保存每月Template.xlsm 的副本。 OP的代码只是在工作表上创建一个列表并将其保存到文件中。我可能会丢失一些格式，通常会从主文件中保存。

getMonthlyFileName(DateOf, Product) - 创建一个文件路径（Root Path \ Date of Date \ Month of Date \ Product - Prodcut mmm.dd.yyyy.xlsx。这样，Product文件可以存放在一个容易的查找结构。

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

Answer 2

为此尝试两个循环，确保按主列表中的产品排序，以使其更快一些。

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

Answer 3

我不知道为什么一些做VBA的人认为在千行代码之前用奇怪的名字声明所有变量是个好主意.........

无论如何......回到这个问题，我相信你想要实现的目标是：

1）在代码遍历列表时指定列表，并根据列出的项过滤数据。 2）创建一个工作簿，其中过滤的数据被复制过来。 3）将工作簿保存到您指定的具有特定名称的位置。

当然，您的程序访问点应该是遍历指定列表的程序访问点，该列表应该是您的主要功能。

然后在main函数中，您将有一个Sub来处理产品ID，然后过滤产品ID，然后将数据复制到新创建的工作簿中。

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

所以这里有一些代码框架，希望能帮助您创建月度报告。您必须自己编写如何将数据从主工作簿复制到目标工作簿（它应该很简单，只需过滤源列表并将结果复制到目标工作簿，没有字典或arraylist是需要）。

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

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

3 个答案: