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