CODEWITHSUNDEEP
vbaexcel
Adavid02
Adavid02

Reputation: 189

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

Saving the files

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"

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

 '### 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)

'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

Upvotes: 0

Views: 1081

Answers (2)

David Zemens
David Zemens

Reputation: 53623

Here, you're overwriting the assignment of Name, this is probably a typo and should be 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\"

In your SaveAs statements, you probably need a path separator in between fName and section name. 

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

I think you may also be able to omit the extension from this string, as it will save the correct file type based on the specified parameter for FileFormat argument:

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

Additional (Potential) Problems:

  1. You're making 2 copies of Sheets(x) without a destination. This immediately creates the copied sheet as a new workbook, which then becomes the ActiveWorkbook.
  2. You're saving the file (the second file that was created in #1 above) as Name and Name2, then you're Killing Name again, after the SaveAs operation. This seems unnecessary and/or unintended.
  3. I notice you're saving the entire workbook, not just the single worksheet. Is that intended? If not, this could be handled by using Sheets(x).SaveAs... or Sheets("Section " & x).SaveAs...
  4. You're doing ActiveWindow.Close inside the loop, which seems suspect, since you're first Saving the ActiveWorkbook.

A Solution?

A mapping solution like the other answer, or using a Dictionary object (my preference) is applicable here, but can't properly be implemented until the rest of your code is actually doing what you expect it to do, and does not contain logical errors or other problems as potentially mentioned above.

Below modified from @A.S.H's answer above, so you'll need the array of secfol that is provided in that answer (see below for one way of including this):

 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

Then create separate function, like so:

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

Upvotes: 0

A.S.H
A.S.H

Reputation: 29332

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

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

Upvotes: 1

Related Questions