有时候我们需要把一大堆的Excel文件合并一个文件,这时候我们可以想到利用VBA来做。
这涉及到遍历文件夹以及子文件夹,找出所有的文件,并且读取文件把它们的内容合并到同一个Excel文件中去。
下面的代码可以实现这样的操作。
Sub MergeData()
Dim strFileName As String
Dim strFolder As String
Dim row As Integer
Dim col As Integer
Dim outRow As Integer
Dim fob As Object
Dim fFile As file
Set fso = CreateObject("scripting.filesystemobject")
'中间变量worksheet
Dim wsTemp As Worksheet
'中间变量workbook
Dim wbTemp As Workbook
Dim strMergedFilePath As String
Dim wbMerged As Workbook
'输出用worksheet变量
Dim wsMerged As Worksheet
'输出用地区名
Dim strOutFolderName As String
'输出用城市名
Dim strOutFileName As String
Application.Visible = False
Application.ScreenUpdating = False
strMergedFilePath = ThisWorkbook.Path & "\"
Set wsMerged = ThisWorkbook.Sheets(2)
wsMerged.Name = "test"
strFolder = Cells(2, 3).Value
If Dir(strFolder, 16) = Empty Then
MsgBox "Folder not exits!", vbOKOnly
End If
Dim file() As String
Dim f As String
Dim i, k
i = 2
k = 1
ReDim file(1 To 1)
'获取所有的子文件夹
f = Dir(strFolder & "\", vbDirectory)
Do Until f = ""
If InStr(f, ".") = 0 Then
k = k + 1
ReDim Preserve file(1 To k)
file(k) = f
End If
f = Dir
Loop
On Error Resume Next
outRow = 3
Do While i <= k
strOutFolderName = file(i)
strFileName = Dir(strFolder & "\" & file(i) & "\*.xlsx", vbDirectory)
Do While strFileName <> ""
strOutFileName = strFileName
Set wbTemp = Workbooks.Open(strFolder & "\" & file(i) & "\" & strFileName)
Set wsTemp = wbTemp.Sheets("test")
If wsTemp Is Nothing Then
Else
If outRow = 3 Then
row = 2
Else
row = 3
End If
Do While wsTemp.Cells(row, 1).Value <> ""
If outRow = 3 Then
wsMerged.Cells(outRow, 1).Value = "地区"
wsMerged.Cells(outRow, 2).Value = "城市"
Else
wsMerged.Cells(outRow, 1).Value = strOutFolderName
wsMerged.Cells(outRow, 2).Value = strOutFileName
End If
col = 1
Do While wsTemp.Cells(row, col).Value <> ""
wsMerged.Cells(outRow, col + 2).Value = wsTemp.Cells(row, col).Value
col = col + 1
Loop
row = row + 1
outRow = outRow + 1
Loop
End If
wbTemp.Close
strFileName = Dir
Loop
i = i + 1
Loop
wsMerged.Activate
'wbMerged.SaveAs (strMergedFilePath & "MergedData.xlsx")
Application.Visible = True
End Sub