Excel VBA保存到具有唯一名称的多个文件夹 [英] Excel VBA Save Sheets to Multiple Folders with Unique Names
问题描述
感谢您的所有输入。下面的代码是收到的输入的顶点。我已经评论了直接关系到保存到数组中定义的文件夹的整体所需结果的错误。
Thank you for all of the input. The code below is a culmination of the input received. I have commented on the errors which directly pertain to the overall desired result of saving into the folders defined in the array.
Option Explicit
Public EngName As String, TeamNum As Variant
Public x As Integer
Option Base 1
'### From David Zemens ###
Function secfol(i As Long)
secfol = Array("", _
"Section 1 Jobs Released Last Week (excludes NRT Jobs)", _
"Section 2 Jobs Created Last Week (excludes NRT Jobs)", _
"Section 3 Late Jobs", _
"Section 4 Unnegotiated Jobs", _
"Section 5 Jobs To Go (Excludes NRT Jobs)", _
"Section 6 Jobs To Go (NRT Jobs)")(i)
End Function
Sub ADMS_Processing()
Application.ScreenUpdating = False
'Opens files and copies worksheets to one workbook and names each worksheet
Dim strFilePath As String
Dim Name As String
Workbooks.Open Filename:= _
"\\MARNV006\BM\Master Scheduling\DSC 2.3.4 Engineering Job Release Metrics\EDW Crystal Reports (Automation)\ePortfolio1.xls"
Sheets(1).Name = "Section 1"
'=======================================================================
' Save file to "Schedule Update Requests" folder & Closes Excel
'=======================================================================
Name = "\\MARNV006\BM\Master Scheduling\DSC 2.3.4 Engineering Job Release Metrics\"
Name = Name & "EDW Crystal Reports (Automation)\Test files\ADMS Combined File"
Name = Name & Format(Date, "_mm-d-yy") & ".xls"
'Deletes file if it already exists
On Error Resume Next
Kill (Name)
ActiveWorkbook.SaveAs Filename:=Name, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Name = "ADMS Combined File" & Format(Date, "_mm-d-yy") & ".xls"
'This gets the downloaded reports "ePortfolio" 1-6 and Saves indivdiual files for each Section, Section 1-6, which are the Sheets of the combined file
'###The Sections (Sheets) are not currently being saved as individual files. There should be 7 files; one for each sheet and a combined file.
'Opens moves the worksheet and closes files for sections 2 through 6
For x = 2 To 6
strFilePath = "\\MARNV006\BM\Master Scheduling\DSC 2.3.4 Engineering Job Release Metrics\"
strFilePath = strFilePath & "EDW Crystal Reports (Automation)\ePortfolio"
strFilePath = strFilePath & x & ".xls"
Workbooks.Open Filename:=strFilePath
Sheets(1).Copy After:=Workbooks(Name).Sheets(x - 1)
ActiveSheet.Name = "Section " & x
Workbooks(Right(strFilePath, 15)).Close SaveChanges:=False
Next x
'###The Combined file is being saved correctly, but the individual sheet files are not currently saving
Next x
Call ScrubSheets
Call SaveWS_to_file
End Sub
保存文件
Sub SaveWS_to_file()
Dim i As Long, Name1 As String, Name2 As String, Name3 As String, fName As String, DateString As String, _
sec1fol As String, sec2fol As String, sec3fol As String, sec4fol As String, sec5fol As String, sec6fol As String
For i = 1 To 6
' ### OTHER STUFF IN YOUR CODE... from David Zemens
Name1 = "\\MARNV006\BM\Master Scheduling\DSC 2.3.4 Engineering Job Release Metrics\"
Name1 = Name1 & "EDW Crystal Reports (Automation)\Test files\Section "
Name1 = Name1 & i & ".xls"
Sheets("Section " & x).Copy
ChDir "\\MARNV006\BM\Master Scheduling\DSC 2.3.4 Engineering Job Release Metrics\EDW Crystal Reports (Automation)\Test files"
'###这些仅为第一页第1节
'### These are only being saved for the first Sheet, Section 1
Name2 = "\\insitefs\www\htdocs\c130\comm\metrics\blue\deck_reports\"
Name2 = Name2 & "Section" & i
Name2 = Name2 & ".xls"
Sheets("Section " & i).Copy
ChDir "\\insitefs\www\htdocs\c130\comm\metrics\blue\deck_reports\"
'###该文件目前仅被保存在以下文件夹路径中DateString ###
fName =\marnv006\Bm\Master Scheduling\DSC 2.3.4工程作业发布指标\蓝色甲板\\蓝色甲板
'###添加反斜杠用于测试以更正文件路径###
fName = fName&年（日期）& \
'###这应该像\marnv006＃marnv006\Bm\Master Scheduling\DSC 2.3.4工程作业发布指标\蓝色甲板\蓝色甲板2016 \
'### This file is currently only being saved in the folder path below as DateString ### fName = "\marnv006\Bm\Master Scheduling\DSC 2.3.4 Engineering Job Release Metrics\Blue Deck\Blue Deck " '### Added backslash for testing to correct file path ### fName = fName & Year(Date) & "\" '### This should be like \marnv006#marnv006\Bm\Master Scheduling\DSC 2.3.4 Engineering Job Release Metrics\Blue Deck\Blue Deck 2016\
'Then the array function to get the folder gets the destination folder
'The file path for the first sheet would be like:
'"\\marnv006\#marnv006\Bm\Master Scheduling\DSC 2.3.4 Engineering Job Release Metrics\Blue Deck\Blue Deck 2016\_
'Section 1 Jobs Released Last Week (excludes NRT Jobs)\Section 1_12_19_2016.xls"
DateString = Format(Now, "mm_dd_yyyy")
'Deletes file if it already exists
On Error Resume Next
Kill (Name1)
Kill (Name2)
'from David Zemens
' ### Save the sheet at this loop iteration:
With Sheets("Section " & i)
'应该保存每张表作为独立文件在相应的文件夹中rray函数
'Should save each sheet as separate file in corresponding folder from the array function
'###目前没有保存这里
'### Nothing is currently being saved here
.SaveAs Filename:=fName & "\" & secfol(i) & "_" & DateString, _
FileFormat:=.Parent.FileFormat, _
Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
'Save file in first location
ActiveWorkbook.SaveAs Filename:=Name1, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
'Save file in second location
ActiveWorkbook.SaveAs Filename:=Name2, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End With
Next i
End Sub
Sub ScrubSheets()
Dim lastRow As Long
Dim myRow As Long
Dim US As String
US = "UTILITIES & SUBSYSTEMS"
'Find last row in column A
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
'Loop for all cells in column A from rows 2 to last row
For myRow = 2 To lastRow
'First check value of column G
If Cells(myRow, "G") = "PROPULSION" Then
Cells(myRow, "G") = US
Else
'Then check column H
If Cells(myRow, "H") = "Q3S2531" Then
Cells(myRow, "G") = "FUNCTIONAL TEST"
Else
' Check four character prefixes
Select Case Left(Cells(myRow, "A"), 4)
Case "32EB", "35EB", "32EF", "35EF"
Cells(myRow, "G") = "AVIONICS"
Case Else
'Check 3 character prefixes
Select Case Left(Cells(myRow, "A"), 3)
Case "35W"
Cells(myRow, "G") = "WIRING"
Case "34S"
Cells(myRow, "G") = "SOFTWARE"
Case Else
'Check 2 character prefixes
Select Case Left(Cells(myRow, "A"), 2)
Case "10", "11", "12", "13", "14", "15"
Cells(myRow, "G") = "AIRFRAME"
Case "21", "23"
Cells(myRow, "G") = US '"UTLITLIES & SUBSYSTEMS"
Case "24", "25"
Cells(myRow, "G") = US '"UTLITLIES & SUBSYSTEMS"
End Select
End Select
End Select
End If
End If
Next myRow
Application.ScreenUpdating = True
End Sub
推荐答案
了解你想要实现的内容，但是要使中的代码在中循环使用，这是一个提示。
Not sure I completely understand what you are trying to achieve, but to make the code inside With work in a loop, here is a hint.
您可以先在数组中初始化文件夹名称，如下所示：
You can first initialize your folders names inside an array like this:
secfol = Array("", _
"Section 1 Jobs Released Last Week (excludes NRT Jobs)", _
"Section 2 Jobs Created Last Week (excludes NRT Jobs)", _
"Section 3 Late Jobs", _
"Section 4 Unnegotiated Jobs", _
"Section 5 Jobs To Go (Excludes NRT Jobs)", _
"Section 6 Jobs To Go (NRT Jobs)")
然后将相应的文件夹名称引用为 secfol（ x），如下所示：
and then reference the corresponding folder name as secfol(x), as below:
For i = 1 to 6
Sheets("Section " & x).copy
ActiveWorkbook.SaveAs Filename:=fName & secfol(x) & "_" & DateString & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Next i
这篇关于Excel VBA保存到具有唯一名称的多个文件夹的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
