Excel VBA сохраняет листы в несколько папок с уникальными именами

Спасибо за весь вход. Приведенный ниже код является кульминацией полученного ввода. Я прокомментировал ошибки, которые напрямую связаны с общим желаемым результатом сохранения в папках, определенных в массиве.

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

 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 & Year (Date) & "\" '### Это должно быть как \ marnv006 # marnv006 \ Bm \ Master Scheduling \ DSC 2.3.4 Показатели выпуска служебных программ \ 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) 

«Должен сохранять каждый лист в виде отдельного файла в соответствующей папке из функции массива

'### В настоящее время ничего не сохраняется.

  .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 

Не уверен, что я полностью понимаю, чего вы пытаетесь достичь, но чтобы код внутри. Работа в цикле, вот подсказка.

Вы можете сначала инициализировать имена папок внутри массива следующим образом:

  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) на соответствующее имя папки как secfol(x) , как 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 

Здесь вы переписываете назначение 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\" 

В ваших операторах fName вам, вероятно, нужен разделитель путей между 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. Вы сохраняете файл (второй файл, который был создан в # 1 выше) как Name и Name2 , после этого вы снова Name2 Name после операции SaveAs . Это кажется ненужным и / или непреднамеренным.
  3. Я замечаю, что вы сохраняете всю книгу, а не только один рабочий лист. Это предназначено? Если нет, это можно было бы обработать, используя Sheets(x).SaveAs... или Sheets("Section " & x).SaveAs...
  4. Вы делаете ActiveWindow.Close внутри цикла, который кажется подозрительным, поскольку вы сначала ActiveWorkbook .

Решение?

Решение для сопоставления, такое как другой ответ, или использование объекта Dictionary (мои предпочтения) применимо здесь, но не может быть правильно реализовано до тех пор, пока остальная часть вашего кода фактически не сделает то, что вы ожидаете от него, и не содержит логических ошибок или другие проблемы, как упомянуто выше.

Ниже изменен ответ @ 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 

Затем создайте отдельную функцию, например:

 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 
Interesting Posts

Создание цикла «Для каждого» быстрее

Вставка пустой строки после строки в Excel

Ошибка POWERPIVOT: оператор SQL недействителен. В заявлении не обнаружены столбцы

Как экспортировать коэффициенты регрессионного анализа из RStudio в электронную таблицу или файл csv?

Запуск сохраненного процесса SAS в Excel завершается с ошибкой после двух запусков

Excel VBA – Как вставить значение без формулы?

MySQL определяет 1 результат как текст из запроса SELECT

Как написать синтаксис Excel Interop в синтаксисе EPPLUS

Проверка согласованности данных

Проверить количество столбцов в файле .xls перед загрузкой в ​​RAILS

Извлеките конкретный столбец из другой книги и скопируйте в целевую книгу

Ошибка выполнения в режиме ожидания до версии pdf

Транспонирование данных с ключевым полем, имеющим несколько связанных значений в строке

LINQ и ExcelQueryFactory

Назначение сочетания клавиш для макроса внутри кода

Давайте будем гением компьютера.