使用VBA（宏）解决多Excel文件中的表单合并
2014-08-17 11:30:55   来源：我爱运维网   评论：0 点击：

你是否苦恼超过数十个同样格式的excel文件合并？特别是多部门工作人员协作的情况下。
你是否害怕超过10万行记录的excel文件VBA(宏）的操作？
这里介绍使用VBA（宏）解决多Excel文件中的表单合并，生成超过百万行的excel文件。

1,新建excel,对"sheet1"按右建，选择查看代码，进入VBA（宏）编辑器，如下图：


2、在出来的VBA（宏）编辑中的右框中，贴入如下代码：


 
Sub testabc()
Dim mypath, myname, awbname
Dim wb As Workbook, wbn As String
Dim g As Long
Dim k As Long
Dim num As Long
Dim box As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False '¹Ø±Õ¸æ¾¯Ìáʾ
Application.Calculation = xlCalculationManual '¹Ø±Õ×Ô¶¯¼ÆËã
mypath = ActiveWorkbook.Path
myname = Dir(mypath & "\" & "*.xls*")
awbname = ActiveWorkbook.Name
num = 0
g = 1
k = 1
If Not (ExistSheet("device_detail")) Then
  ThisWorkbook.Sheets.Add Before:=Worksheets(1)
   ActiveSheet.Name = "device_detail"
End If
 
If Not (ExistSheet("bandwidth_detail")) Then
  ThisWorkbook.Sheets.Add Before:=Worksheets(1)
  ActiveSheet.Name = "bandwidth_detail"
End If
 
Do While myname <> ""
If myname <> awbname Then
  Set wb = Workbooks.Open(mypath & "\" & myname)  '¶ÁÈ¡Ò»¸öÎļþ
  num = num + 1
'  With Workbooks(1).ActiveSheet
  With ThisWorkbook.Sheets("device_detail")
    '.Cells(.Range("a65536").End(xlUp).Row + 2, 1) = Left(myname, Len(myname) - 4)
    'wb.Sheets("É豸ÔöÁ¿¹æ»®Ã÷ϸ").UsedRange.Copy
    '.Cells(.Range("A65536").End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteValues
     'Range("a1").Select
     'Selection.End(xlDown).Select
     If (ExistSheet("É豸ÔöÁ¿¹æ»®Ã÷ϸ")) Then
     If num <> 1 Then
       wb.Sheets("É豸ÔöÁ¿¹æ»®Ã÷ϸ").Range("A2:G65536").Copy
     Else
       wb.Sheets("É豸ÔöÁ¿¹æ»®Ã÷ϸ").Range("A1:G65536").Copy
     End If
     .Cells(g, 1).PasteSpecial Paste:=xlPasteValues
     End If
    'wbn = wbn & Chr(13) & wb.Name
  End With
  With ThisWorkbook.Sheets("bandwidth_detail")
     If (ExistSheet("´ø¿í¹æ»®Ã÷ϸ")) Then
     If num <> 1 Then
       wb.Sheets("´ø¿í¹æ»®Ã÷ϸ").Range("A2:G65536").Copy
     Else
       wb.Sheets("´ø¿í¹æ»®Ã÷ϸ").Range("A1:G65536").Copy
     End If
     .Cells(k, 1).PasteSpecial Paste:=xlPasteValues
     End If
  End With
  wb.Close False
 
End If
myname = Dir
g = ThisWorkbook.Sheets("device_detail").UsedRange.Rows.Count + 1
k = ThisWorkbook.Sheets("bandwidth_detail").UsedRange.Rows.Count + 1
Loop
Range("a1").Select
Application.Calculation = xlCalculationAutomatic '¹Ø±Õ×Ô¶¯¼ÆËã
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "¹²ºÏ²¢ÁË" & num & "¸ö¹¤×÷±¡ÖеÄÈ«²¿¹¤×÷±í¡£", vbInformation, "Ìáʾ"
End Sub
 
 
Function ExistSheet(shtName As String) As Boolean
  Dim Sht As Object
  On Error Resume Next
  Set Sht = Sheets(shtName)
  If Err.Number = 0 Then ExistSheet = True
  Set Sht = Nothing
End Function

得到如下图：


3、打开菜单栏“视图”-》“宏”-》“查看宏”，选择“testabc”执行即可开始合并。