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