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 3 Answers
Answers 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 Answers 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 Answers 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 
0 comments:
Post a Comment