一,、【宏代碼】根據(jù)關(guān)鍵字將一個(gè)excel總表分成若干個(gè)單獨(dú)分表的宏代碼(即拆分)

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) '要分表的數(shù)據(jù)所在表
       Set hzwk = ThisWorkbook '分表模版所在的表
   
  On Error Resume Next
  vvv = Application.InputBox("請選要分表數(shù)據(jù)所在工作表關(guān)鍵字的第一個(gè)單元格" & Chr(13) & "注意1;用鼠標(biāo)選擇含關(guān)鍵字的第一個(gè)單元格,不要選標(biāo)題行;2;若第一個(gè)單元格不可見,，也可任選后，手工修改;3;新表會(huì)建在選擇的數(shù)據(jù)表相同目錄下,以關(guān)鍵字+文件名形式命名,有相同名字會(huì)自動(dòng)覆蓋,！", , , , , , , 0)
   
   If vvv = False Then GoTo 100
 '以下是取得選擇的工作表行列做標(biāo)
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)) '選擇的關(guān)鍵字所在列
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樣式變?yōu)锳1樣式
lzm = Split(lzm, "$")(2) '將列數(shù)轉(zhuǎn)為字母
 '以上是取得選擇的工作表行列做標(biāo)
lastrow = ActiveSheet.UsedRange.Rows.Count '用已用區(qū)域,判斷單元格是否為空的方法判斷單列的最末行
zhh = lastrow
For ttt = lastrow To 1 Step -1
If Range(lzm & ttt) <> "" Then Exit For
zhh = zhh - 1
Next
zmh = zhh '用已用區(qū)域,判斷單元格是否為空的方法判斷單列的最末行

'zmh = sjwk.Sheets(bname).Range(lzm & ":" & lzm).Find("*", , , , 1, 2).Row '最末行,此方法在有篩選時(shí)不能正確判斷
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) '逐行拷貝所有明細(xì),是因?yàn)樵砜赡苡泻Y選或隱藏
   Next
 hzwk.Sheets("分表").Activate
   Cells.EntireRow.Hidden = False '拷貝到"分表"后去除隱藏
   Dim WorkRange As Range
Dim Cell As Range
Set WorkRange = Sheets("分表").UsedRange.SpecialCells(xlCellTypeFormulas) '查找有公式的單元格并將有"!"公式的轉(zhuǎn)成值,也就是去除跨表引用的公式,保留本身公式
   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
 
 '以下通過字典取得關(guān)鍵字,通過逐個(gè)篩選關(guān)鍵字,分表為工作簿
   Dim dic, temp, arr
   Dim rng As Range, sxq As Range
   
Set dic = CreateObject("scripting.dictionary") '字典
   '下面一句代碼：設(shè)置上面設(shè)置的工作表中的哪一列的內(nèi)容拆分工作簿
   Set rng = Range(lzm & hh & ":" & lzm & zmh)
   For Each temp In rng.Cells '這個(gè)for循環(huán)實(shí)現(xiàn)該列的不重復(fù)值的篩選
       If Not dic.exists(temp.Value) Then
           dic.Add temp.Value, ""
       End If
   Next
   
   arr = dic.keys '返回此列不重復(fù)值的數(shù)組
   
   For Each temp In arr '這個(gè)For循環(huán)實(shí)現(xiàn)按照不重復(fù)數(shù)組的內(nèi)容新建工作簿,，并刪除不應(yīng)有的內(nèi)容
    
    hzwk.Sheets("分表").Activate
   
       If AutoFilterMode Then AutoFilterMode = False '工作表里有自動(dòng)篩選則取消
       Set sxq = Range("a" & hh - 1 & ":" & lzm & zmh) '篩選區(qū)域
       sxq.AutoFilter ll, temp
       
       Cells.Copy
   
   Workbooks.Add '新建工作簿
   Workbooks(Workbooks.Count).Activate '激活新鍵工作簿
   ActiveSheet.Paste
   Workbooks(Workbooks.Count).SaveAs FileName:=temp & "-" & sjwk.Name '粘貼數(shù)據(jù)后將新工作簿保存為關(guān)鍵字+數(shù)據(jù)源表的名字
Workbooks(Workbooks.Count).Close
Next temp
 
100:
   sjwk.Close
   Cells.Delete Shift:=xlUp '兩次清除"分表"中的數(shù)據(jù),因?yàn)榭赡苡泻Y選,一次清不完
  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

二、【宏代碼】多個(gè)工作簿合并到1個(gè)工作表（即合并）

Sub 合并當(dāng)前目錄下所有工作簿的全部工作表()

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 & "個(gè)工作薄下的全部工作表,。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub

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

三,、【宏代碼】多個(gè)工作簿合并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:-------------------------------------------------------------------------------------

河陽小子              中國第一關(guān)索戲博客