許多人在工作中會遇到數(shù)據(jù)表有很多頁，少的有幾十頁，多的可能有幾百頁，然后需要合并到一個頁面進行數(shù)據(jù)分析，如果是一頁復(fù)制粘貼的話就比較麻煩了。以下小編就介紹一下利用excel的宏計算來解決這個問題，有需要的朋友可以參考哦。
1、原始數(shù)據(jù)所在工作簿包含多個格式相同的工作表，只不過每個工作表內(nèi)容不同，比如說不同人名的工作表數(shù)據(jù)或者不同部門填寫的數(shù)據(jù)。
2、在原始數(shù)據(jù)同目錄下新建一個工作簿，建立兩個工作表，名稱分別為“首頁”和“合并匯總表”。
3、按Alt+F11進入VBA代碼編輯和調(diào)試界面。
4、根據(jù)下圖提示，插入一個模塊。
5、將下述代碼粘貼到模塊空白處(代碼小編放到最下方了)：
6、在“首頁”工作表中按下圖示范插入一個窗體控件并指定宏為插入的代碼名稱。
7、點擊“首頁”工作表中插入的按鈕，根據(jù)提示，瀏覽到原始數(shù)據(jù)工作簿。
8、下一步，用鼠標選擇要合并的數(shù)據(jù)范圍。
注意：每個工作表數(shù)據(jù)可能不一樣，比如說有的是10行數(shù)據(jù)，有的是30行數(shù)據(jù)。在這里我們可以用鼠標選擇任意工作表的一個較大范圍，比如說A1:D100，保證比最多行數(shù)的工作表數(shù)據(jù)還多就可以，一會再刪除空行。
9、點擊確定按鈕，待代碼運行完畢后，所有的數(shù)據(jù)就都合并到了“合并匯總表”中。
10、選中全部數(shù)據(jù)區(qū)域，執(zhí)行自動篩選。然后選擇其中一個字段，選擇“空白”和標題內(nèi)容。
11、然后將篩選出來的無用行鼠標右鍵刪除，再刪除A列整列即可
代碼如下：
Sub CombineSheetsCells()
Dim wsNewWorksheet As Worksheet
Dim cel As Range
Dim DataSource, RowTitle, ColumnTitle, SourceDataRows, SourceDataColumns As Variant
Dim TitleRow, TitleColumn As Range
Dim Num As Integer
Dim DataRows As Long
DataRows = 1
Dim TitleArr()
Dim Choice
Dim MyName$, MyFileName$, ActiveSheetName$, AddressAll$, AddressRow$, AddressColumn$, FileDir$, DataSheet$, myDelimiter$
Dim n, i
n = 1
i = 1
Application.DisplayAlerts = False
Worksheets("合并匯總表").Delete
Set wsNewWorksheet = Worksheets.Add(, after:=Worksheets(Worksheets.Count))
wsNewWorksheet.Name = "合并匯總表"
MyFileName = Application.GetOpenFilename("Excel工作薄 (*.xls*),*.xls*")
If MyFileName = "False" Then
MsgBox "沒有選擇文件!請重新選擇一個被合并文件!", vbInformation, "取消"
Else
Workbooks.Open Filename:=MyFileName
Num = ActiveWorkbook.Sheets.Count
MyName = ActiveWorkbook.Name
Set DataSource = Application.InputBox(prompt:="請選擇要合并的數(shù)據(jù)區(qū)域：", Type:=8)
AddressAll = DataSource.Address
ActiveWorkbook.ActiveSheet.Range(AddressAll).Select
SourceDataRows = Selection.Rows.Count
SourceDataColumns = Selection.Columns.Count
Application.ScreenUpdating = False
Application.EnableEvents = False
For i = 1 To Num
ActiveWorkbook.Sheets(i).Activate
ActiveWorkbook.Sheets(i).Range(AddressAll).Select
Selection.Copy
ActiveSheetName = ActiveWorkbook.ActiveSheet.Name
Workbooks(ThisWorkbook.Name).Activate
ActiveWorkbook.Sheets("合并匯總表").Select
ActiveWorkbook.Sheets("合并匯總表").Range("A" & DataRows).Value = ActiveSheetName
ActiveWorkbook.Sheets("合并匯總表").Range(Cells(DataRows, 2), Cells(DataRows, 2)).Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
DataRows = DataRows + SourceDataRows
Workbooks(MyName).Activate
Next i
Application.ScreenUpdating = True
Application.EnableEvents = True
End If
Workbooks(MyName).Close
End Sub
X
