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

End Sub

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

以下是Microsoft的一些文档：

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

Answer 2

回答第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

您的上述代码需要进行一些调整，以确保每次都引用正确的表单，但wks变量将有很大帮助。

从给定目录中的所有工作表中抓取数据

2 个答案: