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

Question

我正在尝试将一大堆不同工作簿中的数据复制到一个母版 sheet 中，只是将值粘贴到下一个空白列中。这一切似乎都可以正常工作，但在尝试粘贴到母版 sheet 时总是失败。我试过在其他地方寻找类似的问题，但我似乎无法让它们与我正在尝试做的事情一起工作。

我从其他地方抓取了这段代码的大部分内容并进行了修改以适应，您可能可以从一些遗留的评论中看出这一点

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”的方法 'Range' 失败。

EDIT2：更改粘贴尝试以尝试将值写入单元格即：

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

对于从目录中打开的每个工作簿，正确地将 "Test" 键入到主 sheet 上的下一个可用列中。显然将 'Range' 更改为 'Cells' 是可行的，我以为我昨天尝试过但抛出了一个不同的错误抱怨我没有选择正确大小的单元格

Answer 1

尝试这个基本上你需要做的是将 1 添加到 colDest 给你下一个空列。

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

  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.Cells(1, colDest).PasteSpecial Paste:=xlPasteValues

在我需要的地方正确输入了数据，'ToLeft' 有所不同，但 'Range' 不允许我粘贴到 'Cells' 可以粘贴的地方

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

How can I paste data from one spreadsheet to the last column of another?

excel

vba

copy-paste