excel macro to extract first three rows of excel files from a folder and create new file

Hi to all VBA Programmers,

I have some excel files having data and all the files have same column names like this.

Individuals color Rank
1 red 1
2 blue 2
3 green 3
4 yellow 4
5 orange 5
6 blue 6
7 green 7
8 orange 8
9 yellow 9
10 green 10

Now I want to extract top three individuals from all the files in a folders based on Rank column (Basically selecting top rank Individuals) and I want to create separate new file with all the selected top three individual lists. Is it possibile to do with macro? because doing it manually taking so much time to achving my target for doing more than 150 files. I need help to solve this problem. Any help would be highly aprreciated. please see the attched example file for better understanding and sheet what and how i am expecting.
Thanks in advance,

Regards,
Genetist

Dear JBeaucaire,

thank you very for your reply. I want final file contains information like this from all the files in a folder because all files have same column headings.

Individuals color Rank
1 red 1
2 blue 2
3 green 3
like I want to extract information like this from all the files of folder.

Regards,
Genetist

Dear JBeaucaire,

Yes exactly the same i wish to want to have after
Thanks

Regards,
Genetist

So is the Rank column (in each Workbook) already sorted to show the top 3 ranks at the top?

Yes Dear Apo like that only i want
Thanks

Hi..

Try this.. change the strpath to suit..

Private Sub CommandButton1_Click()
    Dim x, w, i As Long, j As Long, jj As Long, cnt As Long, strpath As String
    ' Set Folder to Search
    strpath = "D:\Rank\"
    ' Put all .xls files found in folder (and subfolders) into an array
    x = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & strpath & "*.xls"" /s/b").stdout.readall, vbCrLf)
    ReDim w(1 To UBound(x) * 3)
    cnt = 1
    ' Loop though the array of .xls* files
    For i = LBound(x) To UBound(x) - 1
        ' Open each Workbook and build new array
        With GetObject(x(i))
            y = .Sheets(1).Range("A1").CurrentRegion.Offset(1).Resize(3)
             For j = 1 To 3
                For jj = 1 To 3
                    w(cnt) = Trim(w(cnt) & " " & y(j, jj))
                Next jj
                cnt = cnt + 1
            Next j
            .Close
        End With
    Next i
    ' Put data into Sheet1 of ThisWorkbook
    Sheets("Sheet1").Range("A1").Resize(UBound(x) * 3).Value = Application.Transpose(w)
    Sheets("Sheet1").Range("A1").Resize(UBound(x) * 3, 1).TextToColumns DataType:=xlDelimited, Space:=True
End Sub