Question

我试图将数据从一大堆不同的工作簿复制到一个主表中，仅将值粘贴在下一个空白列中。一切似乎都可以正常运行，但是在尝试粘贴到主表中时总是失败。我曾尝试在其他地方查看类似的问题，但似乎无法让它们与我尝试做的事情一起工作。

我从其他地方获取了大部分代码，并进行了修改以适合您的需求，您可能会从一些剩余的注释中看出来

Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim colDest As Long
Dim Dest As Worksheet

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

'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

    'Change First Worksheet's Background Fill Blue this is where the work occurs
      Set Dest = Workbooks("Master.xlsm").Worksheets(1)
      colDest = Dest.Cells(1, Dest.Columns.Count).End(xlToRight).Column
      wb.Worksheets(1).Range("b3:u83").Copy
      Dest.Range(1, colDest).PasteSpecial Paste:=xlPasteValues

    '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

End Sub

编辑：此行发生错误：

Dest.Range(1, colDest).PasteSpecial Paste:=xlPasteValues

运行时错误“ 1004”：对象“ _Worksheet”的方法“范围”失败。

EDIT2：通过将值写入单元格的方式更改粘贴尝试，即：

Dest.Cells(1, colDest) = "Test"

对于从目录打开的每个工作簿，在母版工作表的下一个可用列中正确键入“测试”。显然将“范围”更改为“单元格”作品，我以为我昨天尝试过，但是引发了另一个错误，抱怨我没有选择正确尺寸的单元格

Answer 1

基本上，您需要做的是在colDest上加1，以得到下一个空列。

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
Dim colDest As Long
Dim Dest As Worksheet

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

'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

    'Change First Worksheet's Background Fill Blue this is where the work occurs
      Set Dest = Workbooks("Master.xlsm").Worksheets(1)
      colDest = Dest.Cells(1, Dest.Columns.Count).End(xlToLeft).Column + 1
      wb.Worksheets(1).Range("b3:u83").Copy
      Dest.Range(1, colDest).PasteSpecial Paste:=xlPasteValues

    '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

End Sub

Answer 2

下面是一些有关如何在最后一列之后找到导入值的准则。

Option Explicit

Sub Test()

    Dim LastColumn As Long

        With ThisWorkbook.Worksheets("Sheet1")

            'Last Column using UsedRange (NOT A GOOD IDEA)
            LastColumn = .UsedRange.Columns(.UsedRange.Columns.Count).Column
            'Last Column using specific row 7
            LastColumn = .Cells(7, .Columns.Count).End(xlToLeft).Column

            'Add a value in row 5 & after last column
            .Cells(5, LastColumn + 1).Value = ""

        End With

End Sub

Answer 3

exit status 139

在需要的地方正确输入数据，“ ToLeft”有所不同，但“ Range”不允许我粘贴“ Cells”所在的地方

如何将数据从一个电子表格粘贴到另一个电子表格的最后一列？

3 个答案: