☰

Excel VBA - 复制和粘贴宏循环将每个文件粘贴到最后一个

tag-icon • tag-icon microsoft-excel vba macros microsoft-excel-2016
Excel VBA - 复制和粘贴宏循环将每个文件粘贴到最后一个

我有一个关于宏未按预期执行的问题。我使用在线找到的一个脚本来循环遍历同一目录中的多个文件并对每个文件执行相同的操作，并在各种简单操作上对其进行了测试（例如删除前两行、将某一列涂成蓝色等）。

但是，我现在想用它做一些稍微复杂一点的事情，那就是循环浏览文件，选择一个区域，然后将其复制并粘贴到另一个文件（Destination.xlsm）中。第一列的列标题在 A3 中，所以我的想法是选择 A3，按住 ctrl&down 键到达已经在那里的数据的末尾，然后使用 Offset 向下移动 1 个单元格，然后粘贴下一个文件。我意识到当粘贴区域为空时这会导致错误，因为它会进入最后一个可能的单元格，然后尝试从那里向下移动 1 个单元格，这是不可能的。这是我添加了 If 语句的时候，因此如果 A4 为空，它会从 A3 向下移动 1 个单元格并粘贴。如果 A4 不为空，则意味着已经粘贴了一些数据，因此它会转到这里的末尾，然后向下移动 1 个单元格，然后粘贴。

问题是它将每个连续的文件粘贴到最后一个文件上，循环完成后，我只剩下最后一个文件的内容。据我所知，If 语句应该会阻止它这样做，我想不出这个过程还有什么问题。任何帮助都将不胜感激！

代码如下：

Sub LoopAllExcelFilesInFolder()

'PURPOSE: To loop through all Excel files in a user specified folder and 
perform a set task on them

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

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


'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
  .Title = "Select A Target Folder"
  .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "*.xls*"

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

'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

   'Perform action to be repeated (paste into external file)
   wb.Worksheets(1).Range("A2:N2").Select
   wb.Worksheets(1).Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Workbooks("Destination.xlsm").Sheets("Destination").Activate
ActiveSheet.Range("A3").Select

If IsEmpty(Range("A4").Value) = True Then
ActiveCell.Offset(1, 0).Select
Else
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
End If

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

   wb.Worksheets(1).Activate

'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

'Message Box when tasks are completed
  MsgBox "Task Complete!"

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


End Sub

答案1

因此，事实证明该支票：

If IsEmpty(Range("A4").Value) = True

正在检查保存宏的文件中单元格 A4，而不是目标文件中的单元格，正如我希望的那样，通过包含以下内容：

Workbooks("Destination.xlsm").Sheets("Destination").Activate
ActiveSheet.Range("A3").Select

将支票更改为：

If IsEmpty (Workbooks("Destination.xlsm").Sheets("Destination").Range("A4").Value) = True

现在它已按预期工作。

相关内容