Macro to get first 100 rows after filtering in exc

Question

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.

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.

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.

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.

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.

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

Answer 1

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    

Then you can specify the sourceRange as A1:A100.

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.

EDIT:

First get the filtered data using copy and paste:

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

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