从给定目录中的所有表中抓取数据
我正在尝试创build一个macros，它将从位于特定目录中的所有工作簿中的所有工作表中获取信息。 我是一个VBA新手，所以我基本上限于我可以复制或修改极其有限的编程知识。 我一直在试图修改macros我下面的网站。
如何修改SearchValue行来过滤一般的date？ 我将不得不创build一个新的variables？ 另外，如何修改ShName行来扫描工作簿中的每一张工作表？
Sub ConsolidateErrors() Dim MyPath As String, FilesInPath As String Dim MyFiles() As String Dim SourceRcount As Long, FNum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long, CalcMode As Long Dim rng As Range, SearchValue As String Dim FilterField As Integer, RangeAddress As String Dim ShName As Variant, RwCount As Long MyPath = "C:\Documents and Settings\user\Desktop\New Folder" ShName = 1 RangeAddress = Range("A1:N" & Rows.Count).Address FilterField = 1 SearchValue = "10/21/2010" If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" End If FilesInPath = Dir(MyPath & "*.xl*") If FilesInPath = "" Then MsgBox "No files found" Exit Sub End If FNum = 0 Do While FilesInPath <> "" FNum = FNum + 1 ReDim Preserve MyFiles(1 To FNum) MyFiles(FNum) = FilesInPath FilesInPath = Dir() Loop With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) rnum = 1 If FNum > 0 Then For FNum = LBound(MyFiles) To UBound(MyFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) On Error GoTo 0 If Not mybook Is Nothing Then On Error Resume Next With mybook.Worksheets(ShName) Set sourceRange = .Range(RangeAddress) End With If Err.Number > 0 Then Err.Clear Set sourceRange = Nothing End If On Error GoTo 0 If Not sourceRange Is Nothing Then rnum = RDB_Last(1, BaseWks.Cells) + 1 With sourceRange.Parent Set rng = Nothing .AutoFilterMode = False sourceRange.AutoFilter Field:=FilterField, _ Criteria1:=SearchValue With .AutoFilter.Range RwCount = .Columns(1).Cells. _ SpecialCells(xlCellTypeVisible).Cells.Count - 1 If RwCount = 0 Then Else Set rng = .Resize(.Rows.Count - 1, .Columns.Count). _ Offset(1, 0).SpecialCells(xlCellTypeVisible) If rnum + RwCount < BaseWks.Rows.Count Then rng.Copy BaseWks.Cells(rnum, "A") End If End If End With .AutoFilterMode = False End With End If mybook.Close savechanges:=False End If Next FNum BaseWks.Columns.AutoFit MsgBox "Look at the merge results in the new workbook after you click on OK" End If With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With 结束小组
运行代码时，可以使用InputBox（）方法从用户获取数据。 这是一个简单的例子：
Option Explicit Sub test() Dim SearchValue As String SearchValue = InputBox("Enter Date", "Date, please") If (SearchValue = "") Then Exit Sub ' case when "Cancel" or nothing is entered If (IsDate(SearchValue) = False) Then MsgBox "Sorry, that is not a valid date." Exit Sub End If ' Do other stuff End Sub
以下是Microsoft的一些文档：
http://msdn.microsoft.com/en-us/library/office/aa195768(v=office.11​).aspx
要回答你的第二个问题Also, how would modify the ShName line to scan every single sheet in the workbooks?
试试这个语法…
Dim wks as Worksheet For each wks in myBook.Worksheets 'run code here Next
上面的代码需要调整一下，以确保它每次都引用正确的表单，但是这个wksvariables将会有很大的帮助。