我是VBA的新手，它试图合并多个工作簿中的表并创建一个大型主工作簿。 基本思想是（到目前为止，我已经做了什么）：
这是我当前的代码：
Private Sub Extraction()
Application.ScreenUpdating = False
Dim wkbDest As Workbook
Dim wkbSource As Workbook
Set wkbDest = ThisWorkbook
Dim LastRow As Long
Dim strExtension As String
Const strPath As String = "C:\Users\Documents\Test\"
strExtension = Dir(strPath & "*.xls*")
Do While strExtension <> ""
Set wkbSource = Workbooks.Open(strExtension)
With wkbSource
LastRow = .Sheets("total").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Sheets("Sheet1").Range("A1:N3" & LastRow).Copy wkbDest.Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
.Close savechanges:=False
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
End Sub
我肯定搞砸了它在哪里找到数据，并将其复制并粘贴到主工作簿中。 如果有人可以帮助我修改代码行，我将不胜感激。
谢谢。
答案 0 :(得分：0)
对不起，我在旅途中写了这个脚本，所以没有去测试它。
它几乎跟着你的要求。 从主文件执行脚本。它使用DIR（）遍历目录内的所有文件，并调用Resize子过程，以获取并将范围“ A1：N53”中的值传输到主文件中。
DIR（）将遍历文件路径中的所有文件。对于每个文件，它将抓取sheets（1）range（“ A1：N53”）中的数据（如果不想包含标头，请将其更改为range（“ A2：N53”）。对不起，解释有点explanation昧）< / p>
一旦通过范围获取数据，脚本将简单地调整范围大小，并根据最后一行计数将值转移到Sheets（master）中。
请让我知道它是否有效，请按照评论进行操作，让它继续工作！
谢谢
以下脚本：
Option Explicit
Dim fpath As String
Dim fname As String
Dim wb As Workbook
Dim twb As Workbook
Dim rgSrc As Range
Dim rgDest As Range
Sub foo()
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb = ThisWorkbook
fpath = "C:\Users\Documents\Test\"
fname = Dir(fpath)
Do While fname <> ""
Set twb = Workbooks.Open(fpath & fname)
Call Resize
twb.Close
fname = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Sub Resize()
' Get all the data in the current region?change it to "A2:N53" is you dont want header included from the files in filepath
Set rgSrc = twb.Sheets(1).Range("A1:N53")
'Get the range destination
Set rgDest = wb.Sheets("Master").Cells(wb.Sheets("Master").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
Set rgDest = rgDest.Resize(rgSrc.Rows.Count, rgSrc.Columns.Count)
rgDest.Value2 = rgSrc.Value2
End Sub
答案 1 :(得分：0)
您可以尝试以下已使用了一段时间的代码，并且看起来工作正常。提示框将要求您选择文件，并将所有文件组合到一个堆叠的数据库中。它还将添加一个文件名，以便您可以识别从中选择数据的文件名。下面的代码-让我知道是否有帮助-
Private Declare PtrSafe Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
Sub ChDirNet(szPath As String)
SetCurrentDirectoryA szPath
End Sub
Sub MergeSpecificWorkbooks()
Dim MyPath As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim SaveDriveDir As String
Dim FName As Variant
Dim FirstCell As String
' Set application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
SaveDriveDir = CurDir
' Change this to the path\folder location of the files.
ChDirNet "C:\Users\nik\test"
FName = Application.GetOpenFilename(FileFilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True)
If IsArray(FName) Then
' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
' Loop through all files in the myFiles array.
For FNum = LBound(FName) To UBound(FName)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(FName(FNum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets(1)
FirstCell = "A1"
Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
' Test if the row of the last cell is equal to or greater than the row of the first cell.
If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
Set sourceRange = Nothing
End If
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If the source range uses all columns then
' skip this file.
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.Rows.Count
If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "There are not enough rows in the target worksheet."
BaseWks.Columns.AutoFit
mybook.Close SaveChanges:=False
GoTo ExitTheSub
Else
' Copy the file name in column A.
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = FName(FNum)
End With
' Set the destination range.
Set destrange = BaseWks.Range("B" & rnum)
' Copy the values from the source range
' to the destination range.
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
mybook.Close SaveChanges:=False
End If
Next FNum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
ChDirNet SaveDriveDir
End Sub
Function RDB_Last(choice As Integer, rng As Range)
' A choice of 1 = last row.
' A choice of 2 = last column.
' A choice of 3 = last cell.
Dim lrw As Long
Dim lcol As Integer
Select Case choice
Case 1:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case 2:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
On Error Resume Next
lcol = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
On Error Resume Next
RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
RDB_Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
End Select
End Function