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

Question

谢谢您的所有输入。下面的代码是收到的输入的结晶。我已经评论了这些错误，这些错误直接与保存到数组中定义的文件夹中的总体所需结果有关。

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:= _
"\MARNV006BMMaster SchedulingDSC 2.3.4 Engineering Job Release MetricsEDW Crystal Reports (Automation)ePortfolio1.xls"
Sheets(1).Name = "Section 1"
'=======================================================================
' Save file to "Schedule Update Requests" folder & Closes Excel
'=======================================================================
Name = "\MARNV006BMMaster SchedulingDSC 2.3.4 Engineering Job Release Metrics"
Name = Name & "EDW Crystal Reports (Automation)Test filesADMS 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 = "\MARNV006BMMaster SchedulingDSC 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 = "\MARNV006BMMaster SchedulingDSC 2.3.4 Engineering Job Release Metrics"
Name1 = Name1 & "EDW Crystal Reports (Automation)Test filesSection "
Name1 = Name1 & i & ".xls"
Sheets("Section " & x).Copy
ChDir "\MARNV006BMMaster SchedulingDSC 2.3.4 Engineering Job Release MetricsEDW Crystal Reports (Automation)Test files"
'### These are only being saved for the first Sheet, Section 1
Name2 = "\insitefswwwhtdocsc130commmetricsbluedeck_reports"
Name2 = Name2 & "Section" & i
Name2 = Name2 & ".xls"
Sheets("Section " & i).Copy
ChDir "\insitefswwwhtdocsc130commmetricsbluedeck_reports"
 '### This file is currently only being saved in the folder path below as DateString ###
 fName = "\marnv006BmMaster SchedulingDSC 2.3.4 Engineering Job Release MetricsBlue DeckBlue Deck "
 '### Added backslash for testing to correct file path ###
fName = fName & Year(Date) & ""
 '### This should be like \marnv006#marnv006BmMaster SchedulingDSC 2.3.4 Engineering Job Release MetricsBlue DeckBlue 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#marnv006BmMaster SchedulingDSC 2.3.4 Engineering Job Release MetricsBlue DeckBlue 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)
'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

---

Answer 1

不确定我完全了解您要实现的目标，但是要使With内部的代码在循环中工作，这是一个提示。

您可以在这样的数组中首先初始化文件夹名称：

 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 = "\MARNV006BMMaster SchedulingDSC 2.3.4 Engineering Job Release Metrics"
Name = Name & "EDW Crystal Reports (Automation)Test filesSection "
Name = Name & x & ".xls"
Sheets("Section " & x).Copy
ChDir "\MARNV006BMMaster SchedulingDSC 2.3.4 Engineering Job Release MetricsEDW Crystal Reports (Automation)Test files"
'### Look closely at the below, you're now overwriting `Name` instead of
'    Name2
Name2 = "\insitefswwwhtdocsc130commmetricsbluedeck_reports"
Name = Name & "Section " & x & ".xls"
Name = Name & x & ".xls"
Sheets("Section " & x).Copy
ChDir "\insitefswwwhtdocsc130commmetricsbluedeck_reports"

在SaveAs语句中，您可能需要在fName和截面名称之间的路径分离器。

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

我认为您也可以省略此字符串的扩展名，因为它将基于FileFormat参数的指定参数保存正确的文件类型：

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

附加（潜在）问题：

1. 您正在制作2个无目的地的Sheets(x)副本。这立即将复制的工作表作为新工作簿，然后成为ActiveWorkbook。
2. 您将文件（上面创建的第二个文件）保存为Name和Name2，然后在SaveAs操作之后，您将再次Kill ING Name。这似乎是不必要的和/或意外的。
3. 我注意到您保存了整个工作簿，而不仅仅是单身工作表。这是打算的吗？如果没有，可以使用Sheets(x).SaveAs...或Sheets("Section " & x).SaveAs...
来处理这一点
4. 您正在循环中进行ActiveWindow.Close，似乎怀疑，因为您首先保存ActiveWorkbook。

解决方案？

像其他答案一样的映射解决方案，或使用Dictionary对象（我的偏爱）在这里适用，但是直到您的其余代码实际上正在执行您期望做的事情，并且不适当地实现，并且不正确包含逻辑错误或其他可能提到的问题。

以下从 @A.S.H的答案中修改为上面的答案，因此您需要该答案中提供的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

然后创建单独的函数，例如：

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