從給定目錄中的所有工作表中抓取數據

Question

我試圖創建一個宏，它將從位於特定目錄中的所有工作簿中的所有工作表中獲取信息。我是一名VBA新手，所以我基本上只能使用極其有限的編程知識來複制或修改內容。我一直在試圖修改宏，我在下面的網站下了一個。

我該如何修改SearchValue行來過濾一般的日期？我需要創建一個新變量嗎？另外，如何修改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 

結束子

Answer 1

可以使用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 

下面是來自微軟的一些文件：

http://msdn.microsoft.com/en-us/library/office/aa195768(v=office.11).aspx

Answer 2

要回答你有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 

你上面的代碼wi我們需要調整一下，以確保它每次都引用正確的表格，但這個變量將會有很大的幫助。