1

特定のディレクトリにあるすべてのワークブックのすべてのシートから情報を取得するマクロを作成しようとしています。私は VBA の初心者なので、基本的に、非常に限られたプログラミング知識でコピーまたは変更できるものに制限されています。以下のWebサイトから取得したマクロを変更しようとしています。

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

サブ終了

4

2 に答える 2

0

あなたが持っていた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変数は非常に役立ちます。

于 2012-12-03T21:23:58.693 に答える
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 に答える