合并多个文件并去除重复表头

Sub MergeMultiFiles()
    Dim filePath As String, fileName As String, mergedWorkbookName As String, processedFileNames As String
    Dim Workbook As Workbook
    Dim copyRange As Range
    Dim i As LongPtr
    Dim num As LongPtr
    Dim box As String
    Dim headerCount As Integer
    
    headerCount = 1 ' 表头行数，根据实际情况设置
    Application.ScreenUpdating = False
    filePath = ThisWorkbook.Path
    fileName = Dir(filePath & "\source\" & "*.xlsx")
    mergedWorkbookName = ThisWorkbook.Name
    num = 0
    
    Do While fileName <> ""
        If fileName <> mergedWorkbookName Then
            Set Workbook = Workbooks.Open(filePath & "\source\" & fileName)
            num = num + 1
            With ThisWorkbook.ActiveSheet
                ' .Cells(.Range("A65535").End(xlUp).Row + 2, 1).Value = Left(fileName, Len(fileName) - 5)
                For i = 1 To Workbook.Sheets.Count
                    If num = 1 And i = 1 Then
                        Workbook.Sheets(i).UsedRange.Copy .Cells(1, 1)
                    Else
                        Set copyRange = Workbook.Sheets(i).UsedRange
                        copyRange.Offset(headerCount, 0).Resize(copyRange.Rows.Count - headerCount, copyRange.Columns.Count).Copy .Cells(.Range("A65535").End(xlUp).Row + 1, 1)
                    End If
                Next
            End With
            processedFileNames = processedFileNames & Chr(13) & Workbook.Name
            Workbook.Close False
        End If
        fileName = Dir()
    Loop
    '
    'UsedRange.Columns.AutoFit
    Range("A1").Select
    Application.ScreenUpdating = True
    MsgBox "共合并了" & num & "个工作薄下的全部工作表。文件名如下：" & processedFileNames, vbInformation, "提示"
End Sub

合并当前目录下所有工作簿的全部工作表

Sub 合并当前目录下所有工作簿的全部工作表()

Dim MyPath, MyName, AWbName

Dim Wb As Workbook, WbN As String

Dim G As Long

Dim num As Long

Dim box As String



Application.ScreenUpdating = False

MyPath = ActiveWorkbook.Path

MyName = Dir(MyPath & "\source\" & "*.xlsx")

AWbName = ActiveWorkbook.Name

num = 0

Do While MyName <> ""

If MyName <> AWbName Then

Set Wb = Workbooks.Open(MyPath & "\source\" & MyName)

num = num + 1

With Workbooks(1).ActiveSheet

.Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)

For G = 1 To Sheets.Count

Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)

Next

WbN = WbN & Chr(13) & Wb.Name

Wb.Close False

End With

End If

MyName = Dir

Loop

Range("A1").Select

Application.ScreenUpdating = True

MsgBox "共合并了" & num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"

从其他表中取值到汇总表

image.png

For i = 2 To Sheets.Count

    '将e5日期赋值给统计表的a5
    
    Sheet152.Range("a" & i + 3) = Sheets(i).Range("e5")
    Sheet152.Range("b" & i + 3) = Sheets(i).Range("e6")
    Sheet152.Range("c" & i + 3) = Sheets(i).Range("d13")
Next

操作工作簿

1.删除表

Sub test()
Dim biao As Worksheet
Excel.Application.DisplayAlerts = False
For Each biao In Sheets
    If biao.Name <> "绝不能删除" Then
        biao.Delete
    End If
    
Next

Excel.Application.DisplayAlerts = True

End Sub

2.打开指定位置的工作簿并赋值单元格

Sub dakai()
Application.DisplayAlerts = False
Workbooks.Open Filename:="d:\data2\test.xlsx"
ActiveWorkbook.Sheets(1).Range("a1") = "beijing"
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub

3.拆分工作簿

Sub chaifen()
Dim s As Worksheet
Workbooks.Open Filename:="d:\data2\test.xlsx"
For Each s In Sheets
    s.Copy
    ActiveWorkbook.SaveAs Filename:="d:\data\" & s.Name & ".xlsx"
    ActiveWorkbook.Close    
Next
End Sub