从许多来源批量复制 Excel 工作表

Question

我有 2 个文件夹，一个源文件夹和一个目标文件夹。 我想将位于源文件夹中的每个 excel 源文件的位置 1 中的工作表复制到位于目标文件夹中的相应目标 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