20170706xlVBA城中村改造汇总

Public Sub GatherDataPicker()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = ">>>>>>>>程序正在运行>>>>>>>>"

    On Error GoTo ErrHandler

    Dim StartTime, UsedTime As Variant
    StartTime = VBA.Timer
    
    Dim wb As Workbook
    Dim Sht As Worksheet
    Dim OpenWb As Workbook
    Dim OpenSht As Worksheet
    Const SHEET_INDEX = 1
    Const HEAD_ROW As Long = 3

    Dim FolderPath As String
    Dim FileName As String
    Dim FileCount As Long
    Dim iRow As Long

    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        .Title = "请选取Excel工作簿所在文件夹"
        If .Show = -1 Then
            FolderPath = .SelectedItems(1)
        Else
            MsgBox "您没有选中任何文件夹，本次汇总中断！"
            Exit Sub
        End If
    End With
    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"

    Set wb = Application.ThisWorkbook    '工作簿级别
    Set Sht = wb.Worksheets("汇总表")
    Application.Intersect(Sht.UsedRange.Offset(HEAD_ROW), Sht.Range("A:O")).ClearContents

    'FolderPath = ThisWorkbook.Path & "\"
    FileCount = 0
    FileName = Dir(FolderPath & "*.xls*")
    Do While FileName <> ""
        If FileName <> ThisWorkbook.Name Then
            FileCount = FileCount + 1
            Set OpenWb = Application.Workbooks.Open(FolderPath & FileName)
            With OpenWb
                Set OpenSht = OpenWb.Worksheets(SHEET_INDEX)

                iRow = FileCount + HEAD_ROW
                With OpenSht
                    Sht.Cells(iRow, 1).Value = .Range("C4").Value    '档案号
                    Sht.Cells(iRow, 2).Value = .Range("C3").Value    '姓名
                    Sht.Cells(iRow, 3).Value = .Range("G3").Value    '地址
                    Sht.Cells(iRow, 4).Value = .Range("H31").Value    '总面积
                    Sht.Cells(iRow, 5).Value = .Range("B31").Value    '产权
                    Sht.Cells(iRow, 6).Value = .Range("C31").Value    '规划
                    Sht.Cells(iRow, 10).Value = .Range("E31").Value    '90
                    Sht.Cells(iRow, 14).Value = .Range("G31").Value    '90以后
                End With
                .Close False
            End With
        End If
        FileName = Dir
    Loop
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    UsedTime = VBA.Timer - StartTime
    MsgBox "本次耗时：" & Format(UsedTime, "0.000秒"), vbOKOnly, "Excel Studio "

ErrorExit:
    Set wb = Nothing
    Set Sht = Nothing
    Set OpenWb = Nothing
    Set OpenSht = Nothing
    Set Rng = Nothing


    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
    Exit Sub
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "！", vbCritical, "Excel Studio "
        'Debug.Print Err.Description
        Err.Clear
        Resume ErrorExit
    End If
End Sub