Массовое копирование Excel Sheet из многих источников

Question

У меня есть 2 папки, одна исходная папка и одна папка назначения.Я хочу скопировать лист в позиции 1 из формы каждого исходного файла Excel, расположенного в исходной папке, в соответствующий целевой файл Excel, расположенный в целевой папке.Чтобы было проще, файлы с одинаковыми именами просто находятся в другой папке.

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

Sub MassCopy()
    Dim wbk As Workbook
    Dim SheetName
    Dim Position
    Dim SourceFile, DestinationFile
    SheetName = "test_sheet"
    Position = 1
    SourceFile = "test1.xlsx"
    DestinationFile = "test2.xlsx"
    Windows(SourceFile).Activate
    Sheets("Sheet1").Select
    Sheets("Sheet1").Copy After:=Workbooks(DestinationFile).Sheets(Position)
    Set wsNew = Sheets(Sheets(Position).Index + 1)
    wsNew.Name = SheetName

End Sub

Можно ли заставить его работать для каждого файла в папке источника / назначения?

Answer 1

Да, вы можете использовать комбинацию LOOP и DIR.Ниже приведен шаблон, который я использую, когда мне нужно перебрать папку с файлами и повторить то же действие.Замените myPath на путь к файлу к вашей папке и вставьте код, который вы хотите запустить, где я указал, что вы должны ввести свой код.

Sub LoopThroughAllFiles()

Dim wb As Workbook
Dim myPath As String
Dim myFile As String

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
  myPath = "C:\YourPath\TestFolder\"

  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target Path with Ending Extention
  myFile = Dir(myPath)

'Loop through each Excel file in folder
  Do While myFile <> ""
'Set variable equal to opened workbook
  Set wb = Workbooks.Open(Filename:=myPath & myFile)

'Ensure Workbook has opened before moving on to next line of code
  DoEvents

    'Do your tasks
    Enter the code for the tasks you want to accomplish here.


'Save and Close Workbook
 wb.Close SaveChanges:=True

'Ensure Workbook has closed before moving on to next line of code
  DoEvents

'Get next file name
  myFile = Dir
  Loop

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub