【发布时间】：2017-10-10 03:40:54
【问题描述】：
每个月我都会收到我们的销售报告，其中包含我们销售的商品数量以及产品详细信息，我使用 vba 创建了一个模板，用户可以在其中指定产品，它可以为他们创建一个 Excel 报告。
但是，如果我有多个 Excel 报表而不是只有一个报表，我想扩展/修改。我想用 excel 来区分我输入或列出的许多产品代码。
现在，我在模板中添加了一个名为 list 的选项卡，我可以在其中列出 vba 应该从中读取的产品代码编号（A 列中的 4 位数字），但我需要帮助修改代码，而不是询问用户，它改为读取列表。其次，由于主文件包含所有产品，我可能只需要其中的 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
【问题讨论】：