我有一个像这样的表格中的项目列表:
我的代码遍历每一行并对供应商进行分组,将一些信息复制到每个供应商的工作簿中。在这种情况下有两个唯一的供应商,因此将创建两个工作簿。这很有效。
接下来,我想将每个工作簿保存在特定的文件夹路径中。如果文件夹路径不存在,则应创建该路径。
这是代码片段:
'Check directort and save
Path = "G:\BUYING\Food Specials\4. Food Promotions\(1) PLANNING\(1) Projects\Promo Announcements\" & .Range("H" & i) & "\KW " & .Range("A" & i) & "\"
If Dir(Path, vbDirectory) = "" Then
Shell ("cmd /c mkdir """ & Path & """")
End If
wbTemplate.SaveCopyAs Filename:=Path & file & " - " & file3 & " (" & file2 & ").xlsx"
由于某种原因,如果目录存在,两个工作簿都会被保存,但如果目录不存在并且需要创建,则只有一个工作簿会被保存。
完整代码:
Sub Create()
'On Error GoTo Message
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False
Dim WbMaster As Workbook
Dim wbTemplate As Workbook
Dim wStemplaTE As Worksheet
Dim i As Long
Dim Lastrow As Long
Dim rngToChk As Range
Dim rngToFill As Range
Dim rngToFill2 As Range
Dim rngToFill3 As Range
Dim rngToFill4 As Range
Dim rngToFill5 As Range
Dim rngToFill6 As Range
Dim rngToFill7 As Range
Dim rngToFill8 As Range
Dim rngToFill9 As Range
Dim rngToFil20 As Range
Dim CompName As String
Dim WkNum As Integer
Dim WkNum2 As Integer
Dim WkNum3 As Integer
Dim WkNum4 As Integer
Dim FilePath1 As String
Dim TreatedCompanies As String
Dim FirstAddress As String
'''Reference workbooks and worksheet
Set WbMaster = ThisWorkbook
WkNum = Left(ThisWorkbook.Worksheets(1).Range("C5").Value, (InStr(1, ThisWorkbook.Worksheets(1).Range("C5").Value, " - ")) - 1)
WkNum2 = Trim(WkNum)
WkNum3 = Right(ThisWorkbook.Worksheets(1).Range("C5").Value, (InStr(1, ThisWorkbook.Worksheets(1).Range("C5").Value, " - ")) - 1)
WkNum4 = Trim(WkNum3)
'''Loop through Master Sheet to get wk numbers and supplier names
With WbMaster.Sheets(1)
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 11 To Lastrow
Set rngToChk = .Range("A" & i)
MyWeek = rngToChk.Value
CompName = rngToChk.Offset(0, 5).Value
'Check Criteria Is Met
If MyWeek >= WkNum2 And MyWeek <= WkNum4 And InStr(1, TreatedCompanies, CompName) Or CompName = vbNullString Then
'Start Creation
'''Company already treated, not doing it again
Else
'''Open a new template
On Error Resume Next
Set wbTemplate = Workbooks.Open("G:\BUYING\Food Specials\4. Food Promotions\(1) PLANNING\(1) Projects\Promo Announcements\Announcement Template.xlsx")
Set wStemplaTE = wbTemplate.Sheets(1)
'''Set Company Name to Template
wStemplaTE.Range("C13").Value = CompName
'''Add it to to the list of treated companies
TreatedCompanies = TreatedCompanies & "/" & CompName
'''Define the 1st cell to fill on the template
Set rngToFill = wStemplaTE.Range("A31")
'Remove uneeded announcement rows
'wStemplaTE.Range("A31:A40").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
'On Error GoTo Message21
'Create Folder Directory
file = AlphaNumericOnly(.Range("G" & i))
file2 = AlphaNumericOnly(.Range("C" & i))
file3 = AlphaNumericOnly(.Range("B" & i))
'Check directort and save
Path = "G:\BUYING\Food Specials\4. Food Promotions\(1) PLANNING\(1) Projects\Promo Announcements\" & .Range("H" & i) & "\KW " & .Range("A" & i) & "\"
If Dir(Path, vbDirectory) = "" Then
Shell ("cmd /c mkdir """ & Path & """")
End If
wbTemplate.SaveCopyAs Filename:=Path & file & " - " & file3 & " (" & file2 & ").xlsx"
wbTemplate.Close False
End If
Next i
End With
End Sub
Function AlphaNumericOnly(strSource As String) As String
Dim i As Integer
Dim strResult As String
For i = 1 To Len(strSource)
Select Case Asc(Mid(strSource, i, 1))
Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space
strResult = strResult & Mid(strSource, i, 1)
End Select
Next
AlphaNumericOnly = strResult
End Function