一、【宏代码】根据关键字将一个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:-------------------------------------------------------------------------------------

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