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

Question

Each month I get our sales report and it contains quantities of goods we sold along with product details, and I created a template using vba where user can specify a product and it can create a excel report for them.

However, I would like to expand/modify so if I have multiple excel reports instead of just one report. I would like excel to separate however many product codes I input or listed.

Now, I added a tab called list in my template which I can list the # of product codes (the 4 digit number, in column A) where vba should read from but I need help on modifying the codes so instead of asking the user, it reads the list instead. Secondly, since master file contains all of the products and I maybe just need 20 or 30 of them, I will need the vba codes to be flexible as possible.

The way i set it up, I am basically updating/copying new info from Master file into Monthly Template and re-saving Monthly Template as product codes product as of 9.1.2017 file.

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

I seen no reason why to save copies of Monthly Template.xlsm . The OP's code simply creates a list on a worksheet and saves it to file. I might be some formatting missing that would normally get saved over from the Master File.

getMonthlyFileName(DateOf, Product) - creates a file path (Root Path\\Year of Date\\Month of Date\\Product - Prodcut mmm.dd.yyyy.xlsx. In this way, the Product files can be stored in an easy to lookup structure.

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

Try two loops for this, making sure you sort by the product in the main list to make this a little quicker.

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

---

Edit

Will try to piecemeal something to give at least a lead to splitting into different sheets, rather than having one output sheet (this will not be tested, just free-coding):

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

I don't know why some people doing VBA thinks declaring all the variables with weird names before a thousand lines of code is a good idea.........

Anyways..back to the question, I believe what you are trying to achieve is:

1) Specify a list whilst the code iterates through the list and filters the data based on the listed items. 2) Creates a workbook where the filtered the data is copied over. 3) saving the workbook to somewhere you'll specify, with a specific name.

So naturally, your programme access point should be the one that iterates through the specified list, which should be your main function.

Then inside main function you'll have a Sub that deals with whatever the product ID is, and then filters on your product ID, then copies the data into a newly created workbook.

Last step would be naming the new workbook and saving it close it.

So here is some code skeleton that hopefully will help you with creating the monthly reports. You'll have to write yourself how you want to copy the data from your master workbook to the destination workbook (it should be simple enough, just filter the source list and copy the results to the destination workbook, no dictionary nor arraylist is needed).

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