凡心之旅 / 待分類 / excel工作表和工作簿拆分合并宏代碼(親測...

0 0

   

excel工作表和工作簿拆分合并宏代碼(親測有效!)

2017-11-21  凡心之旅

一、【宏代碼】根據關鍵字將一個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:-------------------------------------------------------------------------------------

河陽小子               中國第一關索戲博客

    本站是提供個人知識管理的網絡存儲空間,所有內容均由用戶發布,不代表本站觀點。如發現有害或侵權內容,請點擊這里 或 撥打24小時舉報電話:4000070609 與我們聯系。

    猜你喜歡

    0條評論

    發表

    請遵守用戶 評論公約

    類似文章 更多
    喜歡該文的人也喜歡 更多

    fun888 <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <蜘蛛词>| <文本链> <文本链> <文本链> <文本链> <文本链> <文本链>