excel工作表和工作簿拆分合并宏代码（亲测有效！）

一、【宏代码】根据关键字将一个excel总表分成若干个单独分表的宏代码(即拆分)

Sub SelectFile()
   With Application
       .Calculation = xlManual
       .MaxChange = 0.001
   End With
   'Application.ScreenUpdating = False
Application.DisplayAlerts = False
Cells.Delete Shift:=xlUp
   
   Dim FileName As Variant
   FileName = Application.GetOpenFilename("Excel 文件 (*.xls),*.xls", , "请选择要分表的工作表所在的位置！", , 0)
   If FileName = False Then Exit Sub
 
    Set sjwk = Workbooks.Open(FileName) '要分表的数据所在表
       Set hzwk = ThisWorkbook '分表模版所在的表
   
  On Error Resume Next
  vvv = Application.InputBox("请选要分表数据所在工作表关键字的第一个单元格" & Chr(13) & "注意1;用鼠标选择含关键字的第一个单元格,不要选标题行;2;若第一个单元格不可见，也可任选后，手工修改;3;新表会建在选择的数据表相同目录下,以关键字+文件名形式命名,有相同名字会自动覆盖！", , , , , , , 0)
   
   If vvv = False Then GoTo 100
 '以下是取得选择的工作表行列做标
wz = InStr(1, vvv, "!")
If wz > 0 Then
bname = Mid(vvv, 2, wz - 2) '工作表名
If Left(bname, 1) = "'" Then bname = Mid(bname, 2, Len(bname) - 2)
Else
bname = ActiveSheet.Name
End If
wz2 = InStr(1, vvv, "R")
wz3 = InStr(1, vvv, "C")
If wz2 > 0 And wz3 > 0 Then
hh = Val(Mid(vvv, wz2 + 1, wz3 - wz2 - 1)) '起始行
ll = Val(Mid(vvv, wz3 + 1, Len(vvv) - wz3)) '选择的关键字所在列
End If
If wz2 > 0 And wz3 = 0 Then
hh = Val(Mid(vvv, wz2 + 1, Len(vvv) - wz2))
ll = 0
End If
If wz2 = 0 And wz3 > 0 Then
hh = 0
ll = Val(Mid(vvv, wz3 + 1, Len(vvv) - wz3))
End If
lzm = Application.ConvertFormula(Formula:="=C" & ll, fromReferenceStyle:=xlR1C1, toReferenceStyle:=xlA1) '将R1C1样式变为A1样式
lzm = Split(lzm, "$")(2) '将列数转为字母
 '以上是取得选择的工作表行列做标
lastrow = ActiveSheet.UsedRange.Rows.Count '用已用区域,判断单元格是否为空的方法判断单列的最末行
zhh = lastrow
For ttt = lastrow To 1 Step -1
If Range(lzm & ttt) <> "" Then Exit For
zhh = zhh - 1
Next
zmh = zhh '用已用区域,判断单元格是否为空的方法判断单列的最末行

'zmh = sjwk.Sheets(bname).Range(lzm & ":" & lzm).Find("*", , , , 1, 2).Row '最末行,此方法在有筛选时不能正确判断
Application.StatusBar = "<工作簿:" & sjwk.Name & " 工作表:" & bname & " 行号:" & hh & "-" & zmh & " 列字母:" & lzm & "> 正在处理,请等待....."
 'MsgBox ("表名:" & bname & "行号:" & hh & "列字母:" & lzm)

 
 Application.ScreenUpdating = False
 sjwk.Sheets(bname).Rows("1:" & hh - 1).Copy hzwk.Sheets("分表").Rows("1:" & hh - 1) '拷贝表头
 For ii = hh To zmh
   sjwk.Sheets(bname).Rows(ii).Copy hzwk.Sheets("分表").Rows(ii) '逐行拷贝所有明细,是因为原表可能有筛选或隐藏
   Next
 hzwk.Sheets("分表").Activate
   Cells.EntireRow.Hidden = False '拷贝到"分表"后去除隐藏
   Dim WorkRange As Range
Dim Cell As Range
Set WorkRange = Sheets("分表").UsedRange.SpecialCells(xlCellTypeFormulas) '查找有公式的单元格并将有"!"公式的转成值,也就是去除跨表引用的公式,保留本身公式
   For Each Cell In WorkRange
If InStr(1, Cell.Formula, "!", 1) Then Cell.Value = Cell.Value
Next Cell
With Application
       .Calculation = xlAutomatic
       .MaxChange = 0.001
       End With
 
 '以下通过字典取得关键字,通过逐个筛选关键字,分表为工作簿
   Dim dic, temp, arr
   Dim rng As Range, sxq As Range
   
Set dic = CreateObject("scripting.dictionary") '字典
   '下面一句代码：设置上面设置的工作表中的哪一列的内容拆分工作簿
   Set rng = Range(lzm & hh & ":" & lzm & zmh)
   For Each temp In rng.Cells '这个for循环实现该列的不重复值的筛选
       If Not dic.exists(temp.Value) Then
           dic.Add temp.Value, ""
       End If
   Next
   
   arr = dic.keys '返回此列不重复值的数组
   
   For Each temp In arr '这个For循环实现按照不重复数组的内容新建工作簿，并删除不应有的内容
    
    hzwk.Sheets("分表").Activate
   
       If AutoFilterMode Then AutoFilterMode = False '工作表里有自动筛选则取消
       Set sxq = Range("a" & hh - 1 & ":" & lzm & zmh) '筛选区域
       sxq.AutoFilter ll, temp
       
       Cells.Copy
   
   Workbooks.Add '新建工作簿
   Workbooks(Workbooks.Count).Activate '激活新键工作簿
   ActiveSheet.Paste
   Workbooks(Workbooks.Count).SaveAs FileName:=temp & "-" & sjwk.Name '粘贴数据后将新工作簿保存为关键字+数据源表的名字
Workbooks(Workbooks.Count).Close
Next temp
 
100:
   sjwk.Close
   Cells.Delete Shift:=xlUp '两次清除"分表"中的数据,因为可能有筛选,一次清不完
  Cells.Delete Shift:=xlUp
   Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.StatusBar = False
   
    Set dic = Nothing
   'With Application
      ' .Calculation = xlAutomatic
       '.MaxChange = 0.001
      ' End With
     MsgBox ("分表操作完毕,请到所选文件目录下查看!")
End Sub

二、【宏代码】多个工作簿合并到1个工作表（即合并）

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 & "\" & "*.xls")
 AWbName = ActiveWorkbook.Name
 Num = 0
 Do While MyName <> ""
 If MyName <> AWbName Then
 Set Wb = Workbooks.Open(MyPath & "\" & MyName)
 Num = Num + 1
 With Workbooks(1).ActiveSheet
 .Cells(.Range("A65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
 For G = 1 To Sheets.Count
 Wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").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, "提示"
End Sub

（*.xls格式可依情况修改）

三、【宏代码】多个工作簿合并1工作簿（即合并）

Sub CombineWorkbooks()
    Dim FilesToOpen
    Dim x As Integer

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    FilesToOpen = Application.GetOpenFilename(FileFilter: = "MicroSoft Excel文件(*.xls),*.xls",MultiSelect: = True,Title: = "要合并的文件")

    If TypeName(FilesToOpen) = "Boolean" then
        MsgBox "没有选中文件"
        Goto ExitHandler
    end if

    x = 1
    While x <= UBound(filestoopen)
        Workbooks.Open fileName: = filestoopen(x)
        Sheets().Move After: = ThisWorkbook.Sheets (ThisWorkbook.Sheets.Count)
        x = x + 1
    Wend
 ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub
 ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
 End Sub

SIGNATRE:-------------------------------------------------------------------------------------

河阳小子              中国第一关索戏博客