macros在Excel中过滤后获得前100行
我有一个600.txt文件 – 但只有当打开excel文件，他们显示良好的结构。 他们每个由三列和大约18000行组成。
我的任务是打开它们中的每一个，按C列中的值按降序对它们进行sorting，先取100，将它们复制到单独的工作表中，并使第一行变为粗体（在新工作表中复制这100行的第一行）。 所以最终的结果将是一个工作表，它是从每个文件中收集所有最大值为100的行，清晰地显示加粗的行。
我决定用macros来完成工作，但由于我没有VBA编程经验，所以我search了很多问题，但最后在采用其他一些macros（主要是尝试和失败的方法）后，我想出了解。 它工作得很好，而且它工作。 但问题是我不明白这个代码的行为，现在我需要做其他的事情，而且我被卡住了。
我再次从相同的600个.txt文件开始，我需要打开它们中的每一个，但是这次按照升序对它们进行sorting，过滤它们，只留下那些高于平均水平的文件，并且取前100行，将它们复制在单独的工作表中，并使第一个大胆。
我不知道如何做到这一点。 我最大的问题是过滤后，第一行实际上不是第一行，但其他一些值取决于值，所以我不能指定范围是A2：C101。
感谢您提供任何build议或解决scheme来完成此任务。
编辑，使自己清楚：主要问题是，当我过滤数据，我不知道的方式采取第100行，因为过滤后的数（excel lables）的行不像1,2,3sorting后，但他们依赖在价值观，如我可以得到像5,6,8,21 …所以我的问题是如何采取这个范围？
而第一个任务的代码是（我知道这是混乱的，但我最好）：
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 Dim c As Range Dim SrchRng As Range Dim SrchStr As String SrchStr = "null" Set SrchRng = mybook.Worksheets(1).Range("C1:C18000") Do Set c = SrchRng.Find(SrchStr, LookIn:=xlValues) If Not c Is Nothing Then c.EntireRow.Delete Loop While Not c Is Nothing If Not mybook Is Nothing Then On Error Resume Next mybook.Worksheets(1).Sort.SortFields.Clear mybook.Worksheets(1).Sort.SortFields.Add Key:=Range("C1:C18000") _ , SortOn:=xlSortOnValues, Order:=xlDescending, 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 = xlGuess .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 问题是sorting是自动插入一个头。 您应该通过将Header参数设置为xlNo来指定没有标题：
With mybook.Worksheets(1).Sort .SetRange Range("A1:C18000") .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With
然后你可以指定sourceRange为A1：A100。
你有没有尝试过使用工具菜单下的Excelmacroslogging器？ 这将为您提供简明的代码和理解它的工作方式提供帮助，然后您可以使用这些知识来简化代码。
编辑：
首先使用复制和粘贴获取过滤的数据：
mybook.Worksheets(1).Range("A1:A18000").SpecialCells(xlVisible).Copy destrange.PasteSpecial xlPasteValues
然后删除离开100行：
Dim lLastRow as long lLastRow = BaseWks.Range("A" & CStr(.Rows.Count)).End(xlUp).Row 'Check we have rows to delete If lLastRow >= rnum Then BaseWks.Range("A" & CStr(rnum + 100) & ":A" & CStr(lLastRow)).EntireRow.Delete End If