VBA將資料從檔案夾合并到Excel中的單個作業表

我剛剛從這個論壇找到了下面的 vba 代碼，并試圖包含要復制的 excel 檔案的列標題，但沒有運氣。請幫忙。

Sub ConsolidateWorkbooks()
Dim FolderPath As String, Filename As String, sh As Worksheet, ShMaster As Worksheet
Dim wbSource As Workbook, lastER As Long, arr

'adding a new sheet on ThisWorkbook (after the last existing one)
Set ShMaster = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Sheets.count))

Application.ScreenUpdating = False
FolderPath = "P:\FG\03_OtD_Enabling\Enabling\Teams\Enabling_RPA\Other Automations\Excel Merge Several Files\Data\"
Filename = Dir(FolderPath & "*.xls*")
  Do While Filename <> ""
    'set the workbook to be open:
    Set wbSource = Workbooks.Open(Filename:=FolderPath & Filename, ReadOnly:=True)
    For Each sh In ActiveWorkbook.Worksheets    'iterate between its sheets
        lastER = ShMaster.Range("A" & rows.count).End(xlUp).row 'last empty row
        'put the sheet range in an array:
        arr = sh.Range(sh.UsedRange.cells(1, 1).Offset(1, 0), _
                sh.cells(sh.UsedRange.rows.count - sh.UsedRange.row   1, _
                                       sh.UsedRange.Columns.count)).Value
        'drop the array content at once:
        ShMaster.Range("A" & lastER).Resize(UBound(arr), UBound(arr, 2)).Value = arr
    Next sh
    wbSource.Close    'close the workbook
    Filename = Dir()  'find the next workbook in the folder
  Loop
 Application.ScreenUpdating = True
End Sub

uj5u.com熱心網友回復：

合并作業簿

• 這將僅復制每個作業簿的每個第一個作業表的標題。

• 如果你的意思是復制每個作業表的標題，就變得簡單多了即surg，srCount并且sIsFirstWorksheet成為多余：

  For Each sws In swb.Worksheets
      Set srg = sws.UsedRange
      dCell.Resize(srg.Rows.Count, srg.Columns.Count).Value = srg.Value
      Set dCell = dCell.Offset(srg.Rows.Count)
  Next sws
  

• 如果您想要資料集之間的一個或多個空行，您可以輕松實作一個常量（例如Const Gap As Long = 1）并將其添加到“偏移部分”：

  Set dCell = dCell.Offset(srCount   Gap)
  

Option Explicit

Sub ConsolidateWorkbooks()
    Const ProcTitle As String = "Consolidate Workbooks"
    
    Const sFolderPath As String = "P:\FG\03_OtD_Enabling\Enabling\Teams\" _
        & "Enabling_RPA\Other Automations\Excel Merge Several Files\Data\"
    Const sFilePattern As String = "*.xls*"
    
    ' Source (Are there any files?)
    Dim sFileName As String: sFileName = Dir(sFolderPath & sFilePattern)
    If Len(sFileName) = 0 Then
        MsgBox "No files to process.", vbCritical, ProcTitle
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    ' Destination (Workbook - Worksheet - Range (First Cell))
    Dim dwb As Workbook: Set dwb = ThisWorkbook
    Dim dws As Worksheet ' note 'Worksheets vs Sheets':
    Set dws = dwb.Worksheets.Add(After:=dwb.Sheets(dwb.Sheets.Count))
    Dim dCell As Range
    Set dCell = dws.Cells(dws.Rows.Count, 1).End(xlUp).Offset(1)

    ' Source (Variables)
    Dim swb As Workbook
    Dim sws As Worksheet
    Dim surg As Range
    Dim srg As Range
    Dim srCount As Long
    Dim sFilePath As String
    Dim sIsFirstWorksheet As Boolean
    
    Do While Len(sFileName) > 0
        sFilePath = sFolderPath & sFileName
        Set swb = Workbooks.Open(Filename:=sFilePath, ReadOnly:=True)
        sIsFirstWorksheet = True
        For Each sws In swb.Worksheets
            Set surg = sws.UsedRange
            If sIsFirstWorksheet Then ' copy headers
                srCount = surg.Rows.Count
                Set srg = surg
                sIsFirstWorksheet = False
            Else ' don't copy headers
                srCount = surg.Rows.Count - 1
                Set srg = surg.Resize(srCount).Offset(1)
            End If
            dCell.Resize(srCount, srg.Columns.Count).Value = srg.Value
            Set dCell = dCell.Offset(srCount)
        Next sws
        swb.Close SaveChanges:=False
        sFileName = Dir
    Loop
    'dwb.Save
    
    Application.ScreenUpdating = True

    MsgBox "Workbooks consolidated.", vbInformation, ProcTitle

End Sub

標籤：擅长 vba

上一篇：在Excel中使用重置計算運行總和

下一篇：ExcelVBA-匯入.txt時保留源格式