20170706xlVBA城中村改造汇总

Public Sub GatherDataPicker()Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseApplication.Calculation = xlCalculationManualApplication.StatusBar = ">>>>>>>>程序正在运行>>>>>>>>"On Error GoTo ErrHandlerDim StartTime, UsedTime As VariantStartTime = VBA.TimerDim wb As WorkbookDim Sht As WorksheetDim OpenWb As WorkbookDim OpenSht As WorksheetConst SHEET_INDEX = 1Const HEAD_ROW As Long = 3Dim FolderPath As StringDim FileName As StringDim FileCount As LongDim iRow As LongWith Application.FileDialog(msoFileDialogFolderPicker).InitialFileName = ThisWorkbook.Path.AllowMultiSelect = False.Title = "请选取Excel工作簿所在文件夹"If .Show = -1 ThenFolderPath = .SelectedItems(1)ElseMsgBox "您没有选中任何文件夹，本次汇总中断！"Exit SubEnd IfEnd WithIf 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 = 0FileName = Dir(FolderPath & "*.xls*")Do While FileName <> ""If FileName <> ThisWorkbook.Name ThenFileCount = FileCount + 1Set OpenWb = Application.Workbooks.Open(FolderPath & FileName)With OpenWbSet OpenSht = OpenWb.Worksheets(SHEET_INDEX)iRow = FileCount + HEAD_ROWWith OpenShtSht.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    '90Sht.Cells(iRow, 14).Value = .Range("G31").Value    '90以后End With.Close FalseEnd WithEnd IfFileName = DirLoop'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>UsedTime = VBA.Timer - StartTimeMsgBox "本次耗时：" & Format(UsedTime, "0.000秒"), vbOKOnly, "Excel Studio "ErrorExit:Set wb = NothingSet Sht = NothingSet OpenWb = NothingSet OpenSht = NothingSet Rng = NothingApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueApplication.Calculation = xlCalculationAutomaticApplication.StatusBar = FalseExit Sub'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ErrHandler:If Err.Number <> 0 ThenMsgBox Err.Description & "！", vbCritical, "Excel Studio "'Debug.Print Err.DescriptionErr.ClearResume ErrorExitEnd If
End Sub