1

I am trying to create a macro that will grab information from all sheets in all workbook(s) located in a specific directory. I am a VBA newbie, so I'm basically limited to what I can copy or modify with extremely limited programming knowledge. I have been trying to modify the macro I got off a website below.

How would I modify the SearchValue line to filter any date in general? Would I have to create a new variable? Also, how would modify the ShName line to scan every single sheet in the workbooks?

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

4

2 回答 2

0

您可以在代码运行时使用 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

于 2012-12-03T21:13:01.897 回答
0

回答你的第二个问题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变量将有很大帮助。

于 2012-12-03T21:23:58.693 回答