时间戳

首页 > 解决方案 > VBA将数据从文件夹合并到Excel中的单个工作表

excel - 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

标签： excelvba

解决方案

合并工作簿

  • 这将仅复制每个工作簿的每个第一个工作表的标题。

  • 如果您打算复制每个工作表的标题，它会变得简单得多，即变得surg多余：srCountsIsFirstWorksheet

    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

推荐阅读