Question

谁能帮我注释一下这段代码啊。VBA小白看不懂，,越详细越好，谢谢您了

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

Answer 1

根据代码，在一个目录中存在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