Сохранение части нескольких рабочих листов в виде отдельных файлов CSV

Question

Связанные: Save each sheet in a workbook to separate CSV files

Я унаследовал некоторый код, который я пытаюсь обновить. Цель состоит в том, чтобы взять определенный диапазон от каждого из определенных (макросгенерированных) листов и сохранить их в виде отдельных CSV-файлов. Вот существующий код, несколько упрощен & с проверкой ошибок удалено:

' Save sheets not named "Table" as CSV files 
Sub Extract_CSV() 
    Dim CurrentSheet As Integer 
    For CurrentSheet = 1 To ActiveWorkbook.Worksheets.Count 
     ActiveWorkbook.Worksheets(CurrentSheet).Activate 
     With ActiveWorkbook.Worksheets(CurrentSheet) 
      If (.Name <> "Table") Then 
       .Range("J3:J322").Select 
       .SaveAs Filename:=ActiveSheet.Name, FileFormat:=xlCSV, CreateBackup:=True 
      End If 
     End With 
    Next CurrentSheet 
End Sub 

Линией .Range("J3:J322").Select является Noop в этом контексте, но как я могу добиться того, что это пытается сделать: сохранить только диапазон J3: J322 к этот новый CSV-файл?

Answer 1

Я дополненной свой код и добавил комментарии. Этот код создает временную книгу, чтобы скопировать/вставить ваш выбор и сохранить его. Временная рабочая книга затем закрывается. Обратите внимание, что этот код будет перезаписывать существующие файлы без подсказок. Если вы хотите просмотреть подсказки, удалите строки Application.DisplayAlerts до и после цикла.

Sub Extract_CSV() 
    Dim wb As Workbook 
    Dim CurrentSheet As Integer 
    For CurrentSheet = 1 To ActiveWorkbook.Worksheets.Count 
     ActiveWorkbook.Worksheets(CurrentSheet).Activate 
     'Suppress Alerts so the user isn't prompted to Save or Replace the file 
     Application.DisplayAlerts = False 
     With ActiveWorkbook.Worksheets(CurrentSheet) 
      If (.Name <> "Table") Then 
       'Select the range and copy it to the clipboard 
       .Range("J3:J322").Select 
       Selection.Copy 
       'Create a temporary workbook and paste the selection into it 
       Set wb = Application.Workbooks.Add 
       wb.Worksheets(1).Paste 
       'Save the temporary workbook with the name of the the sheet as a CSV 
       wb.SaveAs Filename:=ActiveSheet.Name, FileFormat:=xlCSV, CreateBackup:=True 
       'Close the workbook 
       wb.Close 
      End If 
     End With 
     'Restore alerts 
     Application.DisplayAlerts = True 
    Next CurrentSheet 
End Sub 

Answer 2

Вы можете скопировать целевой диапазон, вставить его на новый рабочий лист (вам может понадобиться вставить как значения, а также вставить формат номера), а затем сохранить этот рабочий лист.

Приведенный ниже код воплощает идею. Линии, прокомментированные с '*, добавлены/изменены по сравнению с вашим кодом. Несколько вещей, чтобы иметь в виду:

1. По значениям склейки, вы предотвратить (маловероятно) случае наличия клеток с функциями которых оценивали изменения значений при вставке в недавно созданной книге.

2. Использование rng вместо выбора диапазона является рекомендуемой практикой. Если у вас не так много таких операций, вы, вероятно, не заметите (младшего) времени.

3. Отключение DisplayAlerts устраняет предупреждения во время выполнения макроса (см. this, чтобы узнать, хотите ли вы внести коррективы).

   ' Save sheets not named "Table" as CSV files 
   Sub Extract_CSV() 
       Dim CurrentSheet As Integer 
       For CurrentSheet = 1 To ActiveWorkbook.Worksheets.Count 
        ActiveWorkbook.Worksheets(CurrentSheet).Activate 
        Application.DisplayAlerts = False '* 
        With ActiveWorkbook.Worksheets(CurrentSheet) 
         If (.Name <> "Table") Then 
          '.Range("J3:J322").Select 
          Dim rng As Range '* 
          Set rng = .Range("J3:J322") '* 
          rng.Copy '* 
          Dim wb As Workbook '* 
          Set wb = Application.Workbooks.Add '* 
          wb.Worksheets(1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _ 
           xlNone, SkipBlanks:=False, Transpose:=False '* 
          wb.SaveAs Filename:=ActiveSheet.Name, FileFormat:=xlCSV, CreateBackup:=True '* 
          wb.Close '* 
         End If 
        End With 
        Application.DisplayAlerts = True '* 
       Next CurrentSheet 
   End Sub