このマクロは、ファイルに対する条件付きフィルタリングなしで機能するはずです。
ただし、このマクロを変更して、これらの各ファイルを開き、最小から最大に並べ替え、平均を超えるファイルのみをフィルタリングし、これらから最初の100を取得して新しいワークシートにコピーし、最初に作成するようにする必要があります。これらの100行の行は太字です。
コンテクスト
.txt
filepathにあるフォルダに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行あります。