Excel VBA将表格保存到具有唯一名称的多个文件夹

感谢您的所有input。 下面的代码是收到的input的高潮。 我已经评论了直接与保存到数组中定义的文件夹中的整体期望结果有关的错误。

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" 

'###这些只是保存在第一张，第一部分

 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\" 

'###这个文件当前只保存在以下文件夹path中：DateString ### fName =“\ marnv006 \ Bm \ Master Scheduling \ DSC 2.3.4工程作业版本指标\蓝色甲板\蓝色甲板”## ＃添加反斜线以进行testing以更正文件path### fName = fName＆Year（Date）＆“\”'###这应该像\ marnv006＃marnv006 \ Bm \ Master Scheduling \ DSC 2.3.4工程作业发布指标\蓝色甲板\蓝色甲板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) 

'应该将每张纸作为单独的文件保存在数组函数的相应文件夹中

'###目前没有任何内容正在保存

  .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 

Answer 1

不知道我完全理解你正在努力实现的目标，但是为了使代码在循环中工作，这是一个提示。

您可以首先在数组内初始化文件夹名称，如下所示：

  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) ，如下所示：

  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 

Answer 2

在这里，你正在覆盖Name的赋值，这可能是一个错字，应该是Name2 ：

 '### Initial assignment of Name Name = "\\MARNV006\BM\Master Scheduling\DSC 2.3.4 Engineering Job Release Metrics\" Name = Name & "EDW Crystal Reports (Automation)\Test files\Section " Name = Name & x & ".xls" Sheets("Section " & x).Copy ChDir "\\MARNV006\BM\Master Scheduling\DSC 2.3.4 Engineering Job Release Metrics\EDW Crystal Reports (Automation)\Test files" '### Look closely at the below, you're now overwriting `Name` instead of ' Name2 Name2 = "\\insitefs\www\htdocs\c130\comm\metrics\blue\deck_reports\" Name = Name & "Section " & x & ".xls" Name = Name & x & ".xls" Sheets("Section " & x).Copy ChDir "\\insitefs\www\htdocs\c130\comm\metrics\blue\deck_reports\" 

在您的SaveAs语句中，您可能需要在fName和section名称之间使用path分隔符。

 `.SaveAs Filename:=fName & "\" & sec1fol & ... 

我想你也可以省略这个string的扩展名，因为它会根据FileFormat参数指定的参数保存正确的文件types：

 ActiveWorkbook.SaveAs _ Filename:=fName & "\" & sec1fol & "_" & DateString, _ FileFormat:=xlNormal, Password:="", WriteResPassword:="", _ ReadOnlyRecommended:=False, CreateBackup:=False 

附加（潜在）问题：

1. 您正在制作两张Sheets(x)但没有目的地。 这立即创build复制的工作表作为一个新的工作簿，然后成为ActiveWorkbook 。
2. 您将文件（上面＃1中创build的第二个文件）保存为Name和Name2 ，然后在SaveAs操作之后再次执行Kill ing Name 。 这似乎是不必要的和/或无意的。
3. 我注意到你正在保存整个工作簿，而不仅仅是单个工作表。 这是打算？ 如果没有，这可以通过使用Sheets(x).SaveAs...或Sheets("Section " & x).SaveAs...
4. 你正在做循环内的ActiveWindow.Close ，这似乎是可疑的，因为你是第一次保存ActiveWorkbook 。

一个办法？

类似于其他答案或使用Dictionary对象（我的首选项）的映射解决scheme适用于此处，但在代码的其余部分实际执行您期望的操作之前无法正确实施，并且不包含逻辑错误或上面可能提​​到的其他问题。

下面从@ ASH上面的答案修改，所以你需要在该答案中提供的secfol数组（见下面的一种方式）：

  For i = 1 to 6 ' ### OTHER STUFF IN YOUR CODE... ' ' ' ' ### Save the sheet at this loop iteration: With Sheets("Section " & x) .SaveAs Filename:=fName & "\" & secfol(x) & "_" & DateString, _ FileFormat:=.Parent.FileFormat, _ Password:="", WriteResPassword:="", _ ReadOnlyRecommended:=False, CreateBackup:=False End With Next i 

然后创build单独的function，如下所示：

 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