宏在Excel中过滤后获得前100行 [英] Macro to get first 100 rows after filtering in excel

问题描述

我有600个.txt文件-但仅当以excel文件打开时，它们显示出良好的结构.它们每个都由三列和大约18000行组成.

I have a 600 .txt files - but only when opened as excel file they show good structure. Each of them consists of three columns and around 18000 rows.

我的任务是打开它们中的每一个，以降序对它们在C列中的值进行排序，获取前100个，将它们复制到单独的工作表中，然后将第一行加粗(将这100个中的第一行复制到新工作表中).因此，最终结果将是一个工作表，该工作表是每个文件中所有最大100个值的集合，并带有加粗的行，使边框清晰可见.

My task was to open each of them, sort them on values in C column in descending order, take first 100, copy them in separate worksheet, and make first row bold (first row of those 100 that are copied in new worksheet). So final outcome would be one worksheet which is collection of all maximum 100 values from each file with bold row making border clear.

我已经决定要使用宏来完成工作，但是由于我没有VBA编程经验，因此我在google上搜索并遇到了很多问题，但是最终在采用了其他一些宏之后(主要是通过try and fail方法)提出了解决方案.它运作良好，而且确实奏效.但是问题是我不了解这段代码的行为方式，现在我需要做其他事情，而我被困住了.

I’ve decided to make job done with macro, but since I don’t have VBA programming experience, I googled and had a lot of problems, but finally after adopting some other macros (mostly by try and fail method) I came up with solution. And it works great, and it did job. But the problem is I don’t understand how really this code behaves, and now I need to do other thing, and I’m stuck.

我再次从相同的600个.txt文件开始，我需要打开每个文件，但是这次以升序对它们进行排序，对其进行过滤，以便只剩下那些高于平均值的文件，并排在前100行，将它们复制到单独的工作表中，并使其第一个加粗.

I again start with same 600 .txt files, I need to open each of them, but this time sort them in ascending order, filter them so that I am left with only those which are above average, and take first 100 rows, copy them in separate worksheet and make first one bold.

我不知道如何做到这一点.我最大的问题是过滤后，第一行实际上不是第1行，而是其他一些取决于值的值，因此我无法将范围指定为A2:C101.

And I have no clue how to accomplish this. My biggest problem is that after filtering, first row isn’t actually row 1, but some other value which depends on values, so I cannot specify range to be A2:C101.

感谢您提供有关完成此任务的任何建议或解决方案.

Thank you for any advice or solution for accomplishing this task.

编辑以使自己更清楚:主要问题是，当我过滤数据时，我不知道采用前100行的方式，因为过滤后的行数(excel标签)不像在对1,2,3进行排序之后，但它们取决于值，例如我可以得到5、6、8、21之类的东西...所以我的问题是如何获得该范围?

EDIT to make myself clear: Main problem is that when I filter data I don't know the way to take first 100 rows, because after filtering number(excel lables) of rows are not like after sorting 1,2,3 but they depends on values e.g. I can get something like 5,6,8,21... So my question is how to take this range?

适用于第一个任务的代码是(我知道这很杂乱，但我能做到的最好):

And the code that works for first task is (I know it's messy, but it's best I can):

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

推荐答案

问题是排序是自动插入标题.通过将Header参数设置为 xlNo :

The problem is the sort is inserting a header automatically. You should specify no header by setting the Header argument to xlNo:

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

然后您可以将sourceRange指定为A1:A100.

Then you can specify the sourceRange as A1:A100.

您是否还尝试过在Excel的工具"菜单下使用宏记录器?这将为您提供简洁的代码并了解其工作原理，从而对您大有帮助，因此您可以利用这些知识来简化代码.

Have you also tried using the Macro recorder in Excel under the Tools menu? That will help you a lot with providing you with concise code and understanding how it works, so you can then use that knowledge to simplify your code.

首先使用复制和粘贴获取过滤后的数据:

First get the filtered data using copy and paste:

mybook.Worksheets(1).Range("A1:A18000").SpecialCells(xlVisible).Copy
destrange.PasteSpecial xlPasteValues

然后删除以保留100行:

Then delete to leave 100 rows:

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

这篇关于宏在Excel中过滤后获得前100行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！