Sub 遍历()
Dim MyPath$, MyName$, m&, wb As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
MyPath = ThisWorkbook.Path & "\"
MyName = Dir(MyPath, vbDirectory)
Do While MyName <> ""
If MyName <> "." And MyName <> ".." Then
If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
m = m + 1
With GetObject(MyPath & MyName & "\住房信息.xls")
If m = 1 Then
.Sheets(1).Copy
Set wb = ActiveWorkbook
wb.SaveAs ThisWorkbook.Path & "\合并.xls"
Else
.Sheets(1).Copy Before:=wb.Sheets(1)
wb.Save
End If
wb.ActiveSheet.Name = MyName
.Close False
End With
End If
End If
MyName = Dir
Loop
wb.Close True
Application.ScreenUpdating = True
MsgBox "ok"
End Sub
根据代码，在一个目录中存在N个子目录，且每个目录下都有一个名为:住房信息.xls的文件，要将所以的文件合并到一个工作薄，并将工作表名称更改为子目录名称。将合并后的文件保存为:合并.xls，并保存到当前文件所在的目录。
Sub 遍历()Dim MyPath$, MyName$, m&, wb As Workbook '变量声明 $为文本型，&为整数型
Application.ScreenUpdating = False '禁止屏幕刷新
Application.DisplayAlerts = False '禁止出现任何错误提示
MyPath = ThisWorkbook.Path & "\" '获取当前工作薄路径
MyName = Dir(MyPath, vbDirectory) '开始查找第一项
Do While MyName <> "" '遍历
If MyName <> "." And MyName <> ".." Then '检查是否到末尾
'判断当前是否是目录
If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
m = m + 1
'然后打开该目录里的:住房信息.xls
With GetObject(MyPath & MyName & "\住房信息.xls")
If m = 1 Then '如果第一次循环
.Sheets(1).Copy '则复制当前住户信息.xls的第一张工作表
Set wb = ActiveWorkbook '设定wb为活动工作薄
'并在当前路径存为:合并.xls
wb.SaveAs ThisWorkbook.Path & "\合并.xls"
Else '如果不是第一次循环
'则将 住户信息.xls的第一张工作表复制到 合并.xls的第一张工作表的最前面
.Sheets(1).Copy Before:=wb.Sheets(1)
wb.Save '保存wb
End If
wb.ActiveSheet.Name = MyName '当前工作表的名称命名为目录名称
.Close False '关闭wb
End With
End If
End If
MyName = Dir '下一个目录
Loop
wb.Close True '关闭wb
Application.ScreenUpdating = True '恢复屏幕更新
MsgBox "ok" '弹出对话框，表示完成。
End Sub
