一：放文件

我应该有把文件资源放上去，第一次弄，不知道你们那边能不能看到excel的电子档表格，没有看到，教教我怎么放上去哦

二:自定义代码规整（便于查看）

接下来，我们进行代码解释，因为有很多自定义变量，我先把自定义变量放在一起查看，不然到后面会忘记变量的含义（会晕头转向）

---

ljj = ThisWorkbook.Path '当前“合并工具“”工作簿的地址

lj = .SelectedItems(1) '此为文件夹的路径

Dim d As Object '此为字典

Dim ww As Workbook '工作簿
Dim sh As Worksheet         '工作表
Dim arr(), brr() '数组
Dim wb As Workbook '工作簿
Set ww = ThisWorkbook '当前“合并工具“”工作簿
bt = TextBox1.Text '窗体里面的，标题行数
bw = TextBox2.Text '窗体里面的，表尾行数

Set sht = ww.Worksheets("目录") '当前“合并工具“”工作簿中的“目录”表

For Each sh In ww.Worksheets '“合并工具”簿中历遍每个工作表（注：sh不是固定含义）

f = Dir(lj & "\*.xls*") '目标文件夹中的工作簿的名称

Set wb = Workbooks.Open(lj & "\" & f, 0) '目标文件夹中的工作簿

mc = Split(wb.Name, ".")(0) '工作簿名称

 For Each sh In wb.Worksheets '历遍目标文件夹中的工作簿中的每个工作表

r = sh.UsedRange.Find(What:="*", SearchDirection:=xlPrevious).Row '''SearchDirection查找方向

'用find方法，表中的最后一行

ms = sh.UsedRange.Find(What:="*", Searchorder:=xlByColumns,SearchDirection:=xlPrevious).Column '' '用find方法，表中的最后一列

rs = .UsedRange.Find(What:="*", SearchDirection:=xlPrevious).Row '目标文件的表复制到“合并工具”最后，在“合并工具”簿中来得到最后一行

rs = .UsedRange.Find(What:="*", SearchDirection:=xlPrevious).Row + 1 '如果有同名表，则得出最后一行+1

f = Dir '获取下一个文件名，并将其赋值给变量 f

wj = .SelectedItems(1) ‘CommandButton3中的单个文件路径（其实就是工作簿路径）

For Each shtt In wb.Worksheets '历遍目标工作簿中的每个工作表

d(shtt.Name) = "" '装入字典

ws = .UsedRange.Find(What:="*", SearchDirection:=xlPrevious).Row + 1 '“汇总”表的最后一行+1

---

三：接下是运行代码顺序，点击表中的合并按钮，则弹出窗体

Sub 合并()
合并界面.Show 0
End Sub

四：接下来浏览文件，执行代码，如下：

Private Sub CommandButton1_Click()
ljj = ThisWorkbook.Path
VBA.ChDir ljj
Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
With dlgOpen
    If .Show <> -1 Then MsgBox "您没有选择文件夹！": Exit Sub
    lj = .SelectedItems(1)
End With
End Sub
Private Sub CommandButton2_Click() '''合并按钮
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim ww As Workbook
Dim sh As Worksheet
Dim arr(), brr()
Dim wb As Workbook
Set ww = ThisWorkbook
bt = TextBox1.Text
bw = TextBox2.Text
If lj = "" Then MsgBox "请先选择文件夹！": Exit Sub
If OptionButton1 = False And OptionButton2 = False And OptionButton3 = False And OptionButton4 = False Then MsgBox "请选择合并类型！": Exit Sub
If OptionButton2 = True Or OptionButton3 = True Then
    If bt = "" Then MsgBox "请输入标题行数": Exit Sub
    If bw = "" Then MsgBox "请输入表尾行数，如果没有表尾则表尾行数输入数值0": Exit Sub
End If
Set sht = ww.Worksheets("目录")
t = Timer
sht.[a1].CurrentRegion.Offset(1) = Empty
For Each sh In ww.Worksheets
    If sh.Name <> "目录" Then sh.Delete
Next sh
f = Dir(lj & "\*.xls*")
If OptionButton1 = True Then
    m = 1
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            m = m + 1
            Set wb = Workbooks.Open(lj & "\" & f, 0)
            wb.Worksheets(1).Copy after:=ww.Worksheets(ww.Worksheets.Count)
            mc = Split(wb.Name, ".")(0)
            With ww.Worksheets(ww.Worksheets.Count)
                .Name = mc
            End With
            sht.Cells(m, 1) = m - 1
            sht.Cells(m, 2) = mc
            sht.Hyperlinks.Add anchor:=sht.Cells(m, 2), Address:="", SubAddress:="'" & mc & "'!a1", TextToDisplay:=mc
           wb.Close False
        End If
    f = Dir
    Loop
ElseIf OptionButton2 = True Then
    m = 1
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(lj & "\" & f, 0)
            mc = Split(wb.Name, ".")(0)
            For Each sh In wb.Worksheets
                r = sh.UsedRange.Find(What:="*", SearchDirection:=xlPrevious).Row '''SearchDirection查找方向
                ms = sh.UsedRange.Find(What:="*", Searchorder:=xlByColumns, SearchDirection:=xlPrevious).Column ''
                If r > Val(bt) Then
                    m = m + 1
                    If Not d.exists(sh.Name) Then
                        sh.Copy after:=ww.Worksheets(ww.Worksheets.Count)
                        d(sh.Name) = ""
                        With ww.Worksheets(ww.Worksheets.Count)
                            rs = .UsedRange.Find(What:="*", SearchDirection:=xlPrevious).Row  '''SearchDirection查找方向
                            Columns("a:a").Insert Shift:=xlToRight
                            For i = Val(bt) + 1 To rs
                                .Cells(i, 1) = mc
                            Next i
                            .Rows(rs - Val(bw) - 1 & ":" & rs).Delete
                        End With
                        sht.Hyperlinks.Add anchor:=sht.Cells(m, 2), Address:="", SubAddress:="'" & sh.Name & "'!a1", TextToDisplay:=sh.Name
                    Else
                        With ww.Worksheets(sh.Name)
                            rs = .UsedRange.Find(What:="*", SearchDirection:=xlPrevious).Row + 1
                            sh.Range(sh.Cells(Val(bt) + 1, 1), sh.Cells(r - Val(bw), ms)).Copy .Cells(rs, 2)
                            For i = rs To rs + r - Val(bw) - 1
                                .Cells(i, 1) = mc
                            Next i
                        End With
                    End If
                End If
            Next sh
           wb.Close False
        End If
    f = Dir
    Loop
ElseIf OptionButton3 = True Then
    Set sht = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    Do While f <> "" ''在目录中循环
        If f <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(lj & "\" & f) '打开文件
            m = m + 1
            r = wb.Worksheets(1).UsedRange.Find(What:="*", SearchDirection:=xlPrevious).Row
            If r > Val(bt) Then
                If m = 1 Then
                    wb.Worksheets(1).Copy after:=ww.Worksheets(ww.Worksheets.Count)
                Else
                    With ww.Worksheets(ww.Worksheets.Count)
                        .Name = "全部数据"
                        rs = .UsedRange.Find(What:="*", SearchDirection:=xlPrevious).Row + 1
                        wb.Worksheets(1).Rows(Val(bt) + 1 & ":" & r - Val(bw)).Copy .Cells(rs, 1)
                    End With
                End If
            End If
            wb.Close False
        End If
    f = Dir
    Loop
ElseIf OptionButton4 = True Then
    If wj = "" Then MsgBox "您选择的是[一薄多表合并为一表]，请先选择单个文件！": Exit Sub
    Set wb = Workbooks.Open(wj)
    For Each shtt In wb.Worksheets
        d(shtt.Name) = ""
    Next shtt
    If d.exists("汇总") Then wb.Worksheets("汇总").Delete
    For Each sh In wb.Worksheets
        If sh.Name <> "汇总" Then
            rs = sh.UsedRange.Find(What:="*", SearchDirection:=xlPrevious).Row
            If rs > Val(bt) Then
                m = m + 1
                If m = 1 Then
                    sh.Copy before:=wb.Worksheets(1)
                    wb.Worksheets(1).Name = "汇总"
                    If Val(bw) > 0 Then
                        With wb.Worksheets("汇总")
                            .Rows(rs - Val(bw) - 1 & ":" & rs).Delete
                        End With
                    End If
                Else
                    With wb.Worksheets("汇总")
                        ws = .UsedRange.Find(What:="*", SearchDirection:=xlPrevious).Row + 1
                        sh.Rows(Val(bt) + 1 & ":" & rs - Val(bw)).Copy .Cells(ws, 1)
                    End With
                End If
            End If
        End If
    Next sh
    wb.Close True
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End
End Sub

Sub 合并()
Dim ar As Variant
Dim br()
ReDim br(1 To 50000, 1 To 7)
For Each sh In Sheets
    If sh.Name <> "合并" Then
        r = sh.Cells(Rows.Count, 2).End(xlUp).Row
        ar = sh.Range("a1:g" & r)
        For i = 1 To UBound(ar)
            If Trim(ar(i, 2)) <> "" Then
                n = n + 1
                br(n, 1) = n
                For j = 2 To UBound(ar, 2)
                    br(n, j) = ar(i, j)
                Next j
            End If
        Next i
    End If
Next sh
With Sheets("合并")
    .[a1].CurrentRegion.Offset(4).Clear
    .[a5].Resize(n, UBound(br, 2)) = br
    .[a5].Resize(n, UBound(br, 2)).Borders.LineStyle = 1
End With
MsgBox "合并完毕！"
End Sub

Private Sub CommandButton3_Click() '''选择单个文件
With Application.FileDialog(msoFileDialogFilePicker)
     .Title = "请选择数据源文件"
     .AllowMultiSelect = False   '单选择
     .Filters.Clear   '清除文件过滤器
     .Filters.Add "Excel Files", "*.xls;*.xls*"
     .Filters.Add "All Files", "*.*"          '设置两个文件过滤器
     If .Show <> -1 Then MsgBox "您没有选择需要合并的文件！": Exit Sub 'FileDialog 对象的 Show 方法显示对话框，并且返回 -1（如果您按 OK）和 0（如果您按 Cancel）。
     wj = .SelectedItems(1)
End With
End Sub

Private Sub CommandButton4_Click()
End
End Sub

Private Sub OptionButton1_Click()
If OptionButton1 = True Then
    Me.Label1.Visible = False
    Me.Label2.Visible = False
    Me.TextBox1.Visible = False
    Me.TextBox2.Visible = False
    Me.CommandButton3.Visible = False
End If
End Sub
Private Sub OptionButton2_Click()
If OptionButton2 = True Then
    Me.Label1.Visible = True
    Me.Label2.Visible = True
    Me.TextBox1.Visible = True
    Me.TextBox2.Visible = True
    Me.CommandButton3.Visible = False
Else
    Me.Label1.Visible = False
    Me.Label2.Visible = False
    Me.TextBox1.Visible = False
    Me.TextBox2.Visible = False
    Me.CommandButton3.Visible = True
End If
End Sub


Private Sub OptionButton3_Click()
If OptionButton3 = True Then
    Me.Label1.Visible = True
    Me.Label2.Visible = True
    Me.TextBox1.Visible = True
    Me.TextBox2.Visible = True
    Me.CommandButton3.Visible = False
Else
    Me.Label1.Visible = False
    Me.Label2.Visible = False
    Me.TextBox1.Visible = False
    Me.TextBox2.Visible = False
    Me.CommandButton3.Visible = True
End If
End Sub
Private Sub OptionButton4_Click()
If OptionButton4 = True Then
    Me.Label1.Visible = True
    Me.Label2.Visible = True
    Me.TextBox1.Visible = True
    Me.TextBox2.Visible = True
    Me.CommandButton3.Visible = True
Else
    Me.Label1.Visible = False
    Me.Label2.Visible = False
    Me.TextBox1.Visible = False
    Me.TextBox2.Visible = False
    Me.CommandButton3.Visible = False
End If
End Sub

Private Sub UserForm_Initialize()
Me.Label1.Visible = False
Me.Label2.Visible = False
Me.TextBox1.Visible = False
Me.TextBox2.Visible = False
Me.CommandButton3.Visible = False
End Sub