Excel 多表合并之 VBA 解決方案

by Doodle 7. 十二月 2010 23:06

情況一：單文件多工作表合并，即在一張工作薄中，有多個工作表格，每個表格的內(nèi)容都一致，只是所屬的類別不同?，F(xiàn)在要將所有類別表格里的內(nèi)容全部合并到一張工作表格里。如以下表格（諾基亞零配件清單），一共有200多種型號，每種型號一個清單，現(xiàn)在要將它們?nèi)亢喜⒌揭粡埞ぷ鞅砀窭铩?/p>

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

01Option Explicit 
02  
03' 后面要用的，開始粘貼的行號 
04Private beginRowNo As Long
05  
06' 此過程啟動匯總 
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)遍歷每個表格，將需要匯總的表格里的內(nèi)容一一粘貼到“匯總”表格里 
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 "跳過 " + sheetName 
21            Case "update record": 
22                MsgBox "跳過 " + sheetName 
23            Case "匯總": 
24                MsgBox "跳過 " + sheetName 
25            Case Else: 
26                DoSubtotal (sheetName) 
27        End Select
28    Next i 
29End Sub
30  
31' 此過程用來將指定表格名稱的表格內(nèi)容，復(fù)制粘貼到“匯總”表格里。 
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

然后，將光標(biāo)放置在 CommandButton1_Click 過程中的任意位置，按F5運(yùn)行即可。

情況二：多文件合并，即在一個文件夾里，有多個工作薄文件，它們的第一個表格里的內(nèi)容形式都一樣，現(xiàn)在要將它們?nèi)亢喜⒌揭粋€工作薄里。如一個文件夾內(nèi)，有每天的訂單Excel文件，現(xiàn)在要將全部訂單數(shù)據(jù)合并到一個Excel文件內(nèi)。

解決方案：新建一個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)分別將每個工作薄中的第一個工作表里的內(nèi)容，復(fù)制粘貼到當(dāng)前工作薄的第一張工作表里。 
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

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

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

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

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    ' 主要就是這里，這個循環(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ù)，所有內(nèi)容均由用戶發(fā)布，如發(fā)現(xiàn)有害或侵權(quán)內(nèi)容，請點(diǎn)擊舉報。

国产一级a片免费看高清,亚洲熟女中文字幕在线视频,黄三级高清在线播放,免费黄色视频在线看

Excel 多表合并之 VBA 解決方案