0

このマクロは、ファイルに対する条件付きフィルタリングなしで機能するはずです。

ただし、このマクロを変更して、これらの各ファイルを開き、最小から最大に並べ替え、平均を超えるファイルのみをフィルタリングし、これらから最初の100を取得して新しいワークシートにコピーし、最初に作成するようにする必要があります。これらの100行の行は太字です。

コンテクスト

.txtfilepathにあるフォルダに600個のExcelファイル(実際には拡張子は)がありますC:\Excel。このマクロは、それぞれを開き、最小から最大に並べ替え、それぞれから最初の100を取得し、ファイルが開かれるときに順番に新しいワークシートにコピーして、新しいファイルの最初の各行を太字にします。

コードは次のとおりです。

Sub MergeAllWorkbooks()
    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 isEmpty As String
    isEmpty = "null"

    ' Change this to the path\folder location of your files.
    MyPath = "C:\Excel"

    ' Add a slash at the end of the path if needed.
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    ' If there are no Excel files in the folder, exit.
    FilesInPath = Dir(MyPath & "*.txt")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    ' Fill the myFiles array with the list of Excel files
    ' in the search folder.
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop

    ' Set various application properties.
'    With Application
'        CalcMode = .Calculation
'        .Calculation = xlCalculationManual
'        .ScreenUpdating = False
'        .EnableEvents = False
'    End With

    ' Add a new workbook with one sheet.
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1

    ' Loop through all files in the myFiles array.
    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

                    mybook.Worksheets(1).Sort.SortFields.Clear
                    mybook.Worksheets(1).Sort.SortFields. _
                    Add Key:=Range("C2:C18000"), SortOn:=xlSortOnValues, Order:=xlAscending, _
                    DataOption:=xlSortNormal

                 ' Change this range to fit your own needs.
                With mybook.Worksheets(1)
                    Set sourceRange = .Range("A2:C101")
                End With



                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    ' If source range uses all columns then
                    ' skip this file.
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If

                On Error GoTo 0
                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "There are not enough rows in the target worksheet."
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        ' Copy the file name in column A.

                       ' With sourceRange
                           ' BaseWks.Cells(rnum, "D").Font.Bold = True
                           ' BaseWks.Cells(rnum, "D"). _
                                    Resize(.Rows.Count).Value = MyFiles(FNum)
                       ' End With

                        ' Set the destination range.

                        Set destrange = BaseWks.Range("A" & rnum)



                        With mybook.Worksheets(1).Sort
                                .SetRange Range("A1:C18000")
                                .Header = xlYes
                                .MatchCase = False
                                .Orientation = xlTopToBottom
                                .SortMethod = xlPinYin
                                .Apply
                            End With

                        ' Copy the values from the source range
                        ' to the destination range.
                        With sourceRange
                            BaseWks.Cells(rnum, "A").Font.Bold = True
                            BaseWks.Cells(rnum, "B").Font.Bold = True
                            BaseWks.Cells(rnum, "C").Font.Bold = True
                            'MsgBox (BaseWks.Cells.Address)
                            If ActiveCell.Text = isEmpty Then
                            ActiveCell.Offset(0, 1) = 1
                            ActiveCell.Offset(1).EntireRow.Insert
                            ActiveCell.Offset(1, 1) = 0
                            End If
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value

                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If

        Next FNum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    ' Restore the application properties.
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

マクロは厄介ですが、その役割を果たします。

リサーチ

なんとかマクロを見つけて採用したので、アクティブなワークシートで平均以上のデータのみをフィルタリングし、最初の100個を取得して同じワークブックのsheet2にコピーするマクロを次に示します。

Range("A1").Select
    Selection.AutoFilter
    ActiveSheet.Range("A1:C18000").AutoFilter Field:=3, Criteria1:= _
        xlFilterAboveAverage, Operator:=xlFilterDynamic
   ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Rows("1:100").Copy Destination:=Sheets("Sheet2").Range("A1")

必要に応じてこのマクロを採用しようとすると、この並べ替え部分の後に「複雑な」マクロを配置し、以前のファイルのコピー方法を削除することになります。これを機能させることはできません。

また、私はこの質問をして、フィルタリングされたデータの最初の100行を取得するための1つの可能な解決策を得ました(ここで「単純なマクロ」でこのメソッドを見つける前にこれを尋ねました)が、フィルタリングを実行する方法はまだわかりません。私はこれをできるだけ早く必要とするので、私はこの質問をしています。

PSファイルの構造は3列で、それぞれに約18000行あります。

4

1 に答える 1

1

私はあなたの既存のコードをたどってみましたが、それは正直なところ(あなたが認めている)混乱のようなものです。私はあなたがやろうとしていると私が信じていることを書き直しました。これはScriptingRuntimeコンポーネントに依存しているため、VBAウィンドウで[ツール...参照...]に移動し、[MicrosoftScriptingRuntime]をクリックします。

すでにデータを並べ替えているので、フィルターは必要ありません。また、並べ替える列を指定しないと、コードはAで並べ替えられるので、私はそれを想定しました。

特別な場合は考慮しませんでした...つまり、18000行を超える、平均を超える値が100未満であるなどです。このような状況を処理するために、以前のコードの一部を適応させることができます。

Sub StackExample()

Dim fso As New Scripting.FileSystemObject
Dim fo As Scripting.Folder
Dim f As Scripting.File

Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim wsPaste As Excel.Worksheet

Dim avg As Double
Dim r As Long

    Set fo = fso.GetFolder("C:\Excel\")

    For Each f In fo.Files
        If Right(f.Name, 4) = ".txt" Then

            ' assign the variable objects
            Set wb = Excel.Workbooks.Open(fo.Name & f.Name)
            Set ws = wb.Worksheets(1)
            wb.Worksheets.Add
            Set wsPaste = wb.Worksheets(1)
            wsPaste.Move , ws

            ' text to columns (from TXT file)
            ws.Activate
            ws.Range("A1:A18000").TextToColumns DataType:=xlDelimited, Comma:=True

            ' sort
            With ws.Sort
                .SetRange Range("A1:C18000")
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlSortColumns
                .SortMethod = xlPinYin
                .Apply
            End With

            ' calculate the average
            avg = Excel.WorksheetFunction.Average(ws.Range("A2:A18000"))

            ' find the first row with a value equal to or greater than the average
            For r = 2 To 18000
                If ws.Cells(r, 1).Value >= avg Then Exit For
            Next r

            ' copy the range, then paste
            ws.Range(ws.Cells(r, 1), ws.Cells(r + 99, 3)).Copy
            wsPaste.Activate
            wsPaste.Paste wsPaste.Range("A1")

            ' save and close
            Application.DisplayAlerts = False
            wb.SaveAs Left(f.Name, Len(f.Name) - 4), xlOpenXMLWorkbook
            wb.Close
            Application.DisplayAlerts = True

        End If
    Next f

End Sub
于 2013-02-28T01:14:07.657 に答える