excel宏从多个工作簿复制粘贴到数据表的末尾答案

【问题标题】：excel macro copy paste from multiple workbooks to end o data sheetexcel宏从多个工作簿复制粘贴到数据表的末尾
【发布时间】：2014-08-29 15:21:22
【问题描述】：

我正在尝试进入一个文件夹，打开每个文件，从某个工作表“记录”复制数据，将该数据粘贴到“数据”选项卡上宏所在的文件中。数据应该添加，所以每个文件数据都应该显示出来。我每次都无法将数据粘贴到末尾而不是特定的单元格。我尝试使用变量作为最后一行并对其进行偏移，但粘贴不起作用并不断抛出错误。我迫切需要帮助！我一直在搜索博客几个小时。您可以在下面看到我的代码：

Sub copyMultFilesv2()
    Dim rS As Range, rT As Range, Cel As Range
    Dim wBs As Workbook 'source workbook
    Dim wS As Worksheet 'source sheet
    Dim wT As Worksheet 'target sheet
    Dim x As Long 'counter
    Dim c As String
    Dim arrFiles() As String 'list of source files
    Dim myFile As String 'source file
    Dim RowLast As Long
    Dim csTRng As Range
    Dim csSRng As Range
    Dim lastrow As Long
    Dim datatocopy As Range
    Dim opencell As Range

    '    change these to suit requirements
    Const csMyPath As String = "C:\Users\Whatley Macie\Desktop\TestTWC\" 'source folder
    Const csMyFile As String = "*.xl*" 'source search pattern
    'Set csSRng = Worksheets("Record").Range("A2:Z" & Range("A1").End(xlDown).Row) 'source range
'    Set csTRng = Worksheets("Data").Range("A1").End(xlDown).Offset(1, 0) 'target range make is the end of target

    Application.ScreenUpdating = False
    '   target sheet
    Set wT = ThisWorkbook.Worksheets("Data") 'change to suit

'   aquire list of files
    ReDim arrFiles(1 To 1)
    myFile = Dir$(csMyPath & csMyFile, vbNormal)
    Do While Len(myFile) > 0
        arrFiles(UBound(arrFiles)) = myFile
        ReDim Preserve arrFiles(1 To UBound(arrFiles) + 1)
        myFile = Dir$
    Loop
    ReDim Preserve arrFiles(1 To UBound(arrFiles) - 1)

    Set rT = wT.Range("A" & Rows.count).End(xlUp).Offset(1)

    'c = wT.UsedRange.Rows.count
    'csTRng

    ' loop thru list of files
    For x = 1 To UBound(arrFiles)
        Set wBs = Workbooks.Open(csMyPath & arrFiles(x), False, True) 'open wbook
        Set wS = wBs.Worksheets("Record") 'change sheet to suit


        'datatocopy = wS.Range("A2:Z" & Range("A1").End(xlDown).row).Select
        'datatocopy.PasteSpecial 'xlPasteAll
        Application.CutCopyMode = False

        'opencell = ("A" & c)
        c = ActiveSheet.UsedRange.Rows.count
        'Copy the data
        'wS.Range("A2:Z" & Range("A1").End(xlDown).row).Value = wT.Range("A2").Offset(c).Value
        wS.Range("A2:Z" & Range("A1").End(xlDown).row).Copy
        'wT.Range("A2").Value = wS.Range("A2:Z100").Value
        'Sheets("").Range("A1:B10").Copy
        'Activate the destination worksheet
        wT.Activate
        'Select the target range

        'ActiveCell(c + 1, 1).PasteSpecial xlPasteValues
        Dim target As Range
        Set target = Cells((c + 1), 1)
        'Range("A2").Offset(c, 0).Select
        target.Select
        'Range("A2").Offset(RowOffset:=c).Select

        'Paste in the target destination
        'ActiveCell.Offset (c)
        target.Paste

        Application.CutCopyMode = False
        'rT.Offset(1,0)

        wBs.Close False
        'Set rT = rT.Offset(1) 'next row
        DoEvents

    Next x 'next book

    Erase arrFiles

    Application.ScreenUpdating = True

End Sub

【问题讨论】：

你得到了什么确切的错误信息（你能确认它在target.Paste 行）吗？另外，请查看this question，了解如何避免使用select 和Activate。以这种方式整理您的代码可能会修复您的错误（并使其更加健壮和可读）。

标签： excel vba

【解决方案1】：

我有两个解决方案：（您可能还想在处理此问题时打开屏幕更新）

先选择要粘贴的工作表，然后选择要粘贴到的单元格。
使用数组（您的代码会运行得更快）这是未经测试的，所以请检查我的拼写。

Dim arraySource as variant 'somewhere in the start
'Note: c should be saved as a long not a string
arraySource = wS.Range("A2:Z" & Range("A1").End(xlDown).row)
' populate your array instead of wS.Range("A2:Z" & Range("A1").End(xlDown).row).Copy
wt.range("A" & c : "A" & (c + ubound(arraySource)) = arraySource

再次未经测试，但试一试。

【讨论】：