01_ 合并多簿同名表

Sub 合并文件夹下所有工作簿中同名工作表() '1
    '文件夹下所有工作簿wb所有工作表ws按名称合并保存至新建工作表（但不含子文件夹），但不修改原数据（工作表格式相同）
    Dim dict As Object, Sht As Worksheet, file_path$, file_name$, title_row, end_row, save_file$
'--------------------参数填写：title_row，数字，第1行为1向下递增；end_row，数字；file_path，合并文件夹
    title_row = 1  '表头行数，不参与合并
    end_row = 0    '表尾行数，不参与合并
    file_path = InputBox("请在输入框中输入要操作的文件夹全路径!") & "\" '待合并工作簿所在的文件夹
    'file_path = "C:\Users\y001\Desktop\Test\"
    
    If file_path = "\" Then Exit Sub
    
    file_name = Dir(file_path & "*.xls*")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set dict = CreateObject("scripting.dictionary")
    Set write_wb = Workbooks.Add    '新建工作簿，合并文件
    '新建工作簿默认工作表，防止有同名被合并表，导致整表复制后名称改变；但会缺少表头
    For Each Sht In write_wb.Worksheets
        dict(Sht.Name) = ""
    Next
    Do While file_name <> ""
        Set WB = Workbooks.Open(file_path & file_name)
        For Each Sht In WB.Worksheets
            If Not dict.Exists(Sht.Name) Then  '不存在的，直接复制整表
                dict(Sht.Name) = ""
                Sht.Copy After:=write_wb.Sheets(write_wb.Sheets.Count)
            Else
                Set write_ws = write_wb.Worksheets(Sht.Name)
                '首行为空，会导致后续数据被覆盖
                If WorksheetFunction.CountA(write_ws.Rows(1)) = 0 Then write_ws.Rows(1).Delete
                write_row = write_ws.UsedRange.Rows.Count + 1  '合并工作表的第一个空行写入
                sheet_row = Sht.UsedRange.Rows.Count
                Sht.Rows(title_row + 1 & ":" & sheet_row - end_row).Copy write_ws.Range("A" & write_row)
            End If
            'Exit Do
        Next
        WB.Close (False)
        file_name = Dir  '下一个文件名
    Loop
    '保存文件
    
    write_wb.Sheets("sheet1").Delete: write_wb.Sheets("sheet2").Delete: write_wb.Sheets("sheet3").Delete
    Sheets(1).Select
    
    '----------
    Call Cancel
    Call CtrlG
    '----------
    
    save_file = file_path & "合并表.xlsx"
    write_wb.SaveAs Filename:=save_file
    
    write_wb.Close (False)
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "合并完成!"
End Sub
Sub Cancel()
    For Each wsh In ActiveWorkbook.Sheets
            wsh.Select
            
            '取消颜色标记,取消筛选，取消隐藏
            wsh.Tab.ColorIndex = -4142
            wsh.AutoFilterMode = False
            Cells.EntireRow.Hidden = False
            Cells.EntireColumn.Hidden = False
    Next wsh
End Sub
Sub CtrlG() '2
             
      For Each wsh In ActiveWorkbook.Sheets
            '定位删空行
            On Error Resume Next
                wsh.Range("B1").Activate
                wsh.Columns("A:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                wsh.Range("B1").Select
       Next wsh
       
       Sheets(1).Select
End Sub

Sub usevlookup() '匹配_单月表 3
    Dim wsh As Object, rct As Object
    
    For Each wsh In ActiveWorkbook.Sheets
        wsh.Select
        'rct = wsh.Range("C2", Range("C2").End(xlDown)).Rows.Count + 1
        For i = 2 To wsh.UsedRange.Rows.Count
      
            wsh.Cells(i, 1) = "=VLOOKUP(V" & i & ",IF({1,0},'[合并表.xlsx]" & wsh.Name & "'!$V$1:$V$200," & _
                                                 "'[合并表.xlsx]" & wsh.Name & "'!$A$1:$A$200),2,0)"
            wsh.Cells(i, 2) = "=VLOOKUP(V" & i & ",IF({1,0},'[合并表.xlsx]" & wsh.Name & "'!$V$1:$V$200," & _
                                       "'[合并表.xlsx]" & wsh.Name & "'!$B$1:$B$200),2,0)"
        Next i
    Next wsh
    
    Sheets(1).Select
    
End Sub