![](/img/trans.png)
[英]How to copy data from multiple Excel workbooks in a folder into main sheet?
[英]excel macro copy paste from multiple workbooks to end o data sheet
我正在尝试进入一个文件夹,打开每个文件,从某个表“ Record”中复制数据,然后将该数据粘贴到“ Data”选项卡上宏所在的文件中。 数据应添加,因此每个文件数据应显示。 我很难将数据粘贴到末尾,而不是每次都粘贴到一个特定的单元格。 我尝试使用变量作为最后一行并将其偏移,但是粘贴只是无法正常工作,并不断抛出错误。 我迫切需要帮助! 我一直在搜索博客几个小时。 您可以在下面看到我的代码:
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
我有两种解决方案:(也可以在进行此操作时打开屏幕更新)
。
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
再次未经测试,请尝试一下。
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.