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
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
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
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.