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

　　

轉載于:https://www.cnblogs.com/nextseven/p/7128179.html

總結

以上是生活随笔為你收集整理的20170706xlVBA城中村改造汇总的全部內容，希望文章能夠幫你解決所遇到的問題。

如果覺得生活随笔網站內容還不錯，歡迎將生活随笔推薦給好友。