多个excel文件合并,根据首列值进行反向拆分

Sub Merge()
'执行合并提示,防止误合并
If MsgBox("是否执行文件合并?" & vbNewLine & "执行过程中所有提示框请点击'是'" & vbNewLine & "如果未生成文件,请联系:xxx", vbYesNo, "合并文件说明") = vbNo Then Exit Sub

'定义excel操作主要函数,主文件夹路径,文件集合,第一第一sheet操作对象操作对象,第二第一sheet操作对象操作对象
Dim MyPath$, MyName$, sh As Worksheet, sht As Worksheet, m&
'设置第一操作对象为当前活动中的sheet
Set sh = ActiveSheet
'获取主文件夹路径
MyPath = ThisWorkbook.Path & ""
'获取".xlsx"文件集合
MyName = Dir(MyPath & "*.xlsx")
'关闭屏幕刷新,提升程序运行速度
Application.ScreenUpdating = False
'选中A-I列
Range("A:I").Select
'清空数据
Selection.Clear

'循环操作文件集合
Do While MyName <> ""
'根据文件名判定,前9个字符为"123456789-",且不为"123456789-中心公共"
If MyName <> ThisWorkbook.Name And Left(MyName, 9) = "123456789-" And Left(MyName, 13) <> "123456789-中心公共" Then
'载入对应文件
With GetObject(MyPath & MyName)
'循环操作sheet集合
For Each sht In .Sheets
'如果sheet为空,则跳过
If IsSheetEmpty = IsEmpty(sht.UsedRange) Then
'标识,首个文件特殊操作
m = m + 1
If m = 1 Then
'全sheet复制
sht.[a1].Range("A:I").Copy sh.[a1].Range("A1")
'单元格格式复制,为了保持列宽
sht.[a1].CurrentRegion.Copy sh.[a1]
Else
'第二行复制,至sheet2中最下一行首个单元格
sht.[a1].CurrentRegion.Offset(1).Copy sh.[a65536].End(xlUp).Offset(1)
End If
End If
Next
'关闭,不保存改动
.Close False
End With
End If
'清空文件对象
MyName = Dir
Loop

'将"其他"放置在最下
MyName = Dir(MyPath & "*.xlsx")
Do While MyName <> ""
If MyName <> ThisWorkbook.Name And Left(MyName, 13) = "123456789-中心公共" Then
With GetObject(MyPath & MyName)
For Each sht In .Sheets
If IsSheetEmpty = IsEmpty(sht.UsedRange) Then
sht.[a1].CurrentRegion.Offset(1).Copy sh.[a65536].End(xlUp).Offset(1)
End If
Next
.Close False
End With
End If
MyName = Dir
Loop

Save
'获取时间,格式为201708211718
Times = Format(Now, "yyyymmddhhmm")
'拼接新文件名
filenames = ThisWorkbook.Path & "" + "123456789_" + Times + ".xlsm"
'提示合并成功
MsgBox "合并完毕,新文件为:" + filenames
'生成新文件
ThisWorkbook.SaveCopyAs Filename:=filenames
'开启屏幕刷新
Application.ScreenUpdating = True
End Sub

Sub Splitexcel()
'定义excel操作对象:主文件夹路径,第一sheet操作对象,第二第一sheet操作对象操作对象
Dim MyPath$, sh As Worksheet, sht As Worksheet, m&
'设置第一操作对象为当前活动中的sheet
Set sh = ActiveSheet
'获取主文件夹路径
MyPath = ThisWorkbook.Path & ""
'关闭屏幕刷新,提升程序运行速度
Application.ScreenUpdating = False

'创建dict,存储模块和文化名,模块为key,文件名为value
Dim dict
Set dict = CreateObject("Scripting.Dictionary")
'填充dict
dict.Add "A股", "123456789-A股"
dict.Add "基金", "123456789-基金"
dict.Add "宏观", "123456789-宏观行业"
dict.Add "行业及特色", "123456789-宏观行业"
dict.Add "宏观行业自生产切换", "123456789-宏观行业"
dict.Add "宏观行业其他", "123456789-宏观行业"
dict.Add "新三板", "123456789-新三板"
dict.Add "行情", "123456789-期指行情"
dict.Add "期货期权指数", "123456789-期指行情"
dict.Add "港股", "123456789-港股"
dict.Add "财务", "123456789-财务"
dict.Add "债券", "123456789-债券"
dict.Add "其他", "123456789-中心公共"

'根据dict,依次清除模块excel中除首行外单元格
Dim key
For Each key In dict
'生成文件名
MyName = Dir(MyPath & dict(key) & ".xlsx")
Do While MyName <> ""
'加载文件
With GetObject(MyPath & MyName)
For Each sht In .Sheets
If IsSheetEmpty = IsEmpty(sht.UsedRange) Then
'清空分表首行外数据
sht.Range("A2:j" & [a65536].End(3).Row).Clear
End If
Next
'取消视图隐藏
.Windows(1).Visible = True
'关闭文件,保留修改
.Close True
End With
'清空文件名对象
MyName = ""
Loop
Next

'获取第二列最大行数值,
rown = Range("b65536").End(xlUp).Row

For i = 2 To rown
'首列循环判断,确认各key对应行数
If Range("A" & i).Value <> "" And Range("A" & i).Value <> "其他" Then
n = i + 1
'确认下一个key对应行数
For j = n To rown
If Range("A" & j).Value <> "" Then
'根据第一层循环key,组合文件名
MyName = Dir(MyPath & dict.Item(Range("A" & i).Value) & ".xlsx")
Do While MyName <> ""
'加载文件
With GetObject(MyPath & MyName)
For Each sht In .Sheets
If IsSheetEmpty = IsEmpty(sht.UsedRange) Then
'第二行复制,至sheet2中最下一行首个单元格
sh.Range("A" & i, "I" & j - 1).Copy sht.[a65536].End(xlUp).Offset(1)
End If
Next
'取消视图隐藏
.Windows(1).Visible = True
'关闭文件,保留修改
.Close True
End With
'清空文件名对象
MyName = ""
Loop
'设置j为最大行数,结束第二层循环
j = rown
End If
Next j
'最下的"其他"特殊处理,获取对应行数后,直接复制
ElseIf Range("A" & i).Value = "其他" Then
'组合文件名
MyName = Dir(MyPath & dict.Item(Range("A" & i).Value) & ".xlsx")
Do While MyName <> ""
'加载文件
With GetObject(MyPath & MyName)
For Each sht In .Sheets
If IsSheetEmpty = IsEmpty(sht.UsedRange) Then
'第二行复制,至sheet2中最下一行首个单元格
sh.Range("A" & i, "I" & rown).Copy sht.[a65536].End(xlUp).Offset(1)
End If
Next
'取消视图隐藏
.Windows(1).Visible = True
'关闭文件,保留修改
.Close True
End With
'清空文件名对象
MyName = ""
Loop
End If
Next i
'开启屏幕刷新
Application.ScreenUpdating = True

End Sub