Excel 多表合并之 VBA 解決方案

by Doodle 7. 十二月 2010 23:06

情況一：單文件多工作表合并，即在一張工作薄中，有多個(gè)工作表格，每個(gè)表格的內容都一致，只是所屬的類(lèi)別不同?，F在要將所有類(lèi)別表格里的內容全部合并到一張工作表格里。如以下表格（諾基亞零配件清單），一共有200多種型號，每種型號一個(gè)清單，現在要將它們全部合并到一張工作表格里。

解決方案：插入一張工作表格，命名為“匯總”。按Alt+F11，進(jìn)入VBA編輯器，寫(xiě)上如下代碼：

01Option Explicit 
02  
03' 后面要用的，開(kāi)始粘貼的行號 
04Private beginRowNo As Long
05  
06' 此過(guò)程啟動(dòng)匯總 
07Private Sub CommandButton1_Click() 
08    Dim sheetCount As Integer
09    sheetCount = ThisWorkbook.Worksheets.Count 
10      
11    Dim i As Integer
12    beginRowNo = 1 
13    ' 以下循環(huán)遍歷每個(gè)表格，將需要匯總的表格里的內容一一粘貼到“匯總”表格里 
14    For i = 1 To sheetCount 
15        Dim sheetName As String
16        sheetName = ThisWorkbook.Worksheets(i).Name 
17          
18        Select Case LCase(sheetName) 
19            Case "summary": 
20                MsgBox "跳過(guò) " + sheetName 
21            Case "update record": 
22                MsgBox "跳過(guò) " + sheetName 
23            Case "匯總": 
24                MsgBox "跳過(guò) " + sheetName 
25            Case Else: 
26                DoSubtotal (sheetName) 
27        End Select
28    Next i 
29End Sub
30  
31' 此過(guò)程用來(lái)將指定表格名稱(chēng)的表格內容，復制粘貼到“匯總”表格里。 
32Private Sub DoSubtotal(ByVal sheetName As String) 
33    Dim sourceSheet As Worksheet 
34    Dim destSheet As Worksheet 
35      
36    Set sourceSheet = ThisWorkbook.Worksheets(sheetName) 
37    Set destSheet = ThisWorkbook.Worksheets("匯總") 
38      
39    sourceSheet.UsedRange.Copy 'destSheet.Range("A" & beginrowno) 
40    destSheet.Range("A" & beginRowNo).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, True
41    beginRowNo = beginRowNo + sourceSheet.UsedRange.Rows.Count 
42      
43    Set sourceSheet = Nothing
44    Set destSheet = Nothing
45End Sub

然后，將光標放置在 CommandButton1_Click 過(guò)程中的任意位置，按F5運行即可。

情況二：多文件合并，即在一個(gè)文件夾里，有多個(gè)工作薄文件，它們的第一個(gè)表格里的內容形式都一樣，現在要將它們全部合并到一個(gè)工作薄里。如一個(gè)文件夾內，有每天的訂單Excel文件，現在要將全部訂單數據合并到一個(gè)Excel文件內。

解決方案：新建一個(gè)Excel工作薄，按Alt+F11，進(jìn)入VBA編輯器，輸入如下代碼：

01Sub 合并工作簿() 
02    Dim FilesToOpen 
03    Dim x As Integer
04  
05    On Error GoTo ErrHandler 
06    Application.ScreenUpdating = False
07  
08    FilesToOpen = Application.GetOpenFilename _ 
09      (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _ 
10      MultiSelect:=True, Title:="Files to Merge") 
11  
12    If TypeName(FilesToOpen) = "Boolean" Then
13        MsgBox "No Files were selected"
14        GoTo ExitHandler 
15    End If
16  
17    x = 1 
18    Dim currentWorkSheet As Worksheet 
19    Dim rng As Range 
20    Set currentWorkSheet = ActiveWorkbook.ActiveSheet 
21    Set rng = currentWorkSheet.Range("A1") 
22    Dim wkb As Workbook 
23    Dim wks As Worksheet 
24    ' 以下循環(huán)分別將每個(gè)工作薄中的第一個(gè)工作表里的內容，復制粘貼到當前工作薄的第一張工作表里。 
25    While x <= UBound(FilesToOpen) 
26        Set wkb = Workbooks.Open(Filename:=FilesToOpen(x)) 
27        Set wks = wkb.Worksheets(1) 
28          
29        rng.Offset(0, 10).Value = wkb.Name 
30          
31        wks.UsedRange.Copy rng 
32          
33        Set rng = rng.Offset(wks.UsedRange.Rows.Count, 0) 
34        wkb.Close False
35          
36        x = x + 1 
37    Wend 
38    Set wks = Nothing
39    Set rng = Nothing
40    Set wkb = Nothing
41    Set currentWorkSheet = Nothing
42  
43ExitHandler: 
44    Application.ScreenUpdating = True
45    Exit Sub
46  
47ErrHandler: 
48    MsgBox Err.Description 
49    Resume ExitHandler 
50End Sub

將光標放在過(guò)程“合并工作薄”的任意位置，按F5運行，在彈出的打開(kāi)文件框中，選擇需要合并的全部文件，確定即可。

情況三：多文件合并。類(lèi)似情況二，但是，只將多個(gè)工作薄里的工作表復制到同一個(gè)工作薄里，不需要到同一個(gè)工作表。

解決方案：類(lèi)似情況二，代碼只有一點(diǎn)點(diǎn)區別：

01Sub 合并工作簿2() 
02    Dim FilesToOpen 
03    Dim x As Integer
04  
05    On Error GoTo ErrHandler 
06    Application.ScreenUpdating = False
07  
08    FilesToOpen = Application.GetOpenFilename _ 
09      (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _ 
10      MultiSelect:=True, Title:="Files to Merge") 
11  
12    If TypeName(FilesToOpen) = "Boolean" Then
13        MsgBox "No Files were selected"
14        GoTo ExitHandler 
15    End If
16  
17    x = 1 
18    ' 主要就是這里，這個(gè)循環(huán)處理代碼與情況二稍有不同！ 
19    While x <= UBound(FilesToOpen) 
20        Workbooks.Open Filename:=FilesToOpen(x) 
21          
22        Sheets().Move After:=ThisWorkbook.Sheets _ 
23          (ThisWorkbook.Sheets.Count) 
24            
25        x = x + 1 
26    Wend 
27  
28ExitHandler: 
29    Application.ScreenUpdating = True
30    Exit Sub
31  
32ErrHandler: 
33    MsgBox Err.Description 
34    Resume ExitHandler 
35End Sub

注：如果先做情況三，再做情況一，那么就等于情況二。

本站僅提供存儲服務(wù)，所有內容均由用戶(hù)發(fā)布，如發(fā)現有害或侵權內容，請點(diǎn)擊舉報。

欧美性猛交XXXX免费看蜜桃,成人网18免费韩国,亚洲国产成人精品区综合,欧美日韩一区二区三区高清不卡,亚洲综合一区二区精品久久

Excel 多表合并之 VBA 解決方案