合并文件夹中的工作表并按列追加

Question

我必须编译一个文件夹中的所有工作表，并按列附加它(除了标记文件名之外)。

所有工作表都应具有以下维度。

​

我希望提供以下结果(能够合并文件名是一个额外的奖励)：

​

Sub macro1()
    'Define variables
    Dim wbk As Workbook
    Dim Filename As String
    Dim Path As String
    i = 3
    ThisWorkbook.Activate
    'Location of individual templates
    Path = "filename\"
    Filename = Dir(Path & "*.xlsx")
    'Prevents screen from flickering when Macro is running
    Application.ScreenUpdating = False

    'Start of loop
    Do While Len(Filename) > 0

        'Opens excel file
        Set wbk = Workbooks.Open(Path & Filename)
            
        'Copies the file names
        Sheets("1.Consol").Select
        Range("C3:E3").Select
        ActiveCell.Value = Replace(Filename, ".xlsx", "")
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues
                         
        'Labelling low
        Range("C4").Select
        ActiveCell.Value = "Low"
        Range("C4").Select
        Selection.Copy
        Selection.PasteSpecial xlPasteValues
        
        'Labelling Medium
        Range("D4").Select
        ActiveCell.Value = "Medium"
        Range("D4").Select
        Selection.Copy
        Selection.PasteSpecial xlPasteValues
        
        'Labelling High
        Range("E4").Select
        ActiveCell.Value = "High"
        Range("E4").Select
        Selection.Copy
        Selection.PasteSpecial xlPasteValues
        
        'Copies the whole range of data
        Range("C3:E100").Copy
            
        'Change to the sheet name you want to paste to
        ThisWorkbook.Activate
        Sheets("1.Consol").Select
        Cells(3, i).Select
        ActiveSheet.Paste
        Selection.EntireColumn.ColumnWidth = 10
        Selection.EntireRow.AutoFit
        i = i + 3

        Application.DisplayAlerts = False
        wbk.Saved = True
        wbk.Close True
        Filename = Dir
    Loop

End Sub

Answer 1

基于此设置(请参阅数据的位置)

源文件：

​

​

合并文件：

​

​

按F8键逐步执行代码

阅读代码的注释，并根据您的需要进行调整

Public Sub OpenFilesAndCopyContents()

    ' Basic error handling
    On Error GoTo CleanFail

    ' Turn off stuff
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    ThisWorkbook.UpdateLinks = xlUpdateLinksNever

    ' Define files path
    Dim filesPath As String
    filesPath = "C:\Temp\Test\"
    
    ' Define and set target sheet
    Dim targetSheet As Worksheet
    Set targetSheet = ThisWorkbook.Worksheets("1.Consol")
    
    ' Define initial cell in target sheet
    Dim targetRange As Range
    Set targetRange = targetSheet.Range("B1")
    
    ' Define file name string to match
    Dim fileString As String
    fileString = "samplefile"
    
    ' Define file name
    Dim fileName As String
    fileName = Dir(filesPath, vbNormal)
    
    ' Start a counter for worksheets
    Dim sheetCounter As Long
    
    ' Loop through files
    Do While fileName <> ""
        'Set variable equal to opened workbook
        If InStr(LCase(fileName), LCase(fileString)) > 0 Then
        
            ' Set a reference to the workbook
            Dim sourceWorkbook As Workbook
            Set sourceWorkbook = Workbooks.Open(fileName:=filesPath & fileName, UpdateLinks:=False)
            
            'Ensure Workbook has opened before moving on to next line of code
            DoEvents
            
            ' Loop through sheets in workbook
            Dim sourceSheet As Worksheet
            For Each sourceSheet In sourceWorkbook.Worksheets
            
                ' Add workbook and worksheet as title
                targetRange.Offset(0, sheetCounter).Value = sourceWorkbook.Name & " " & sourceSheet.Name
                
                ' Copy paste values from worksheet
                sourceSheet.Range("B1:D8").Copy targetRange.Offset(1, sheetCounter)
                
                sheetCounter = sheetCounter + 3
                
            Next sourceSheet
            
            'Close Workbook without saving
            sourceWorkbook.Close SaveChanges:=False
            
            'Ensure Workbook has closed before moving on to next line of code
            DoEvents
            
        End If
        
        fileName = Dir()
    Loop

CleanExit:
    ' Turn on stuff
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    ThisWorkbook.UpdateLinks = xlUpdateLinksAlways
    Exit Sub
    
CleanFail:
    MsgBox "Error " & Err.Description
    GoTo CleanExit

End Sub

如果有效，请让我知道