Excel VBA: extract top row of every Worksheet in every workbook within a folder

[Dostonus]

Dear folks
I need Excel VBA procedure to extract top row of every Worksheet in every workbook within a folder
ex:
I have 400 excel files and each worksheet there are top rows that I have to get them all and summarize in one excel sheet for further analysis
Excel VBA Procedure should copy out first rows and paste in new workbook and should loop through all the files, and paste them in the new workbook.

Thank you in advance

 

[EXCEL MAX]

Hello Dostonus,
try this...
Put all excel files for extraction in one folder.
Run this code and navigate to that folder.
This code opens each file and loop through worksheets,
copying first row of each sheet to the new worksheet of the workbook with this code.

Dim varLocation1 As String
Dim varNLoop As Long
Dim varFile, varArray
Dim varI As Integer
Dim varFSO, varOFile, varOFolder, varOFiles As Object
Dim varWB As Workbook, varWB2 As Workbook
Dim varCurrentRow As Long
Dim varWS As Worksheet

Sub ExtractTopRows()
   
    MsgBox ("Select folder with excel files from where you want extraction.")
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
           varLocation1 = .SelectedItems(1)
        Else
            MsgBox ("Select folder with excel files from where you want extraction.")
            Exit Sub
        End If
    End With
    Sheets.Add
    varFile = varListFiles(varLocation1 & "\")
    Set varWB = ActiveWorkbook
    Application.ScreenUpdating = False
    For varNLoop = 1 To varI - 1
        Workbooks.Open varLocation1 & "\" & varArray(varNLoop)
        Set varWB2 = ActiveWorkbook
        For Each varWS In varWB2.Worksheets
            varWS.Activate
            ActiveSheet.Rows(1).Copy
            varWB.Activate
            varCurrentRow = varCurrentRow + 1
            Rows(varCurrentRow).PasteSpecial
        Next varWS
        Application.DisplayAlerts = False
        varWB2.Close
    Next
    Set varFSO = Nothing
    varCurrentRow = 0
    Application.ScreenUpdating = True

End Sub

Function varListFiles(ByVal varPath As String)

    Set varFSO = VBA.CreateObject("Scripting.FileSystemObject")
    Set varOFolder = varFSO.GetFolder(varPath)
    Set varOFiles = varOFolder.Files
    If varOFiles.Count = 0 Then Exit Function
    ReDim varArray(1 To varOFiles.Count)
    varI = 1
    For Each varOFile In varOFiles
        varArray(varI) = varOFile.Name
        varI = varI + 1
    Next

End Function

 

[Dostonus]

Hello Dostonus,
try this...
Put all excel files for extraction in one folder.
Run this code and navigate to that folder.
This code opens each file and loop through worksheets,
copying first row of each sheet to the new worksheet of the workbook with this code.

Dim varLocation1 As String
Dim varNLoop As Long
Dim varFile, varArray
Dim varI As Integer
Dim varFSO, varOFile, varOFolder, varOFiles As Object
Dim varWB As Workbook, varWB2 As Workbook
Dim varCurrentRow As Long
Dim varWS As Worksheet

Sub ExtractTopRows()
  
    MsgBox ("Select folder with excel files from where you want extraction.")
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
           varLocation1 = .SelectedItems(1)
        Else
            MsgBox ("Select folder with excel files from where you want extraction.")
            Exit Sub
        End If
    End With
    Sheets.Add
    varFile = varListFiles(varLocation1 & "\")
    Set varWB = ActiveWorkbook
    Application.ScreenUpdating = False
    For varNLoop = 1 To varI - 1
        Workbooks.Open varLocation1 & "\" & varArray(varNLoop)
        Set varWB2 = ActiveWorkbook
        For Each varWS In varWB2.Worksheets
            varWS.Activate
            ActiveSheet.Rows(1).Copy
            varWB.Activate
            varCurrentRow = varCurrentRow + 1
            Rows(varCurrentRow).PasteSpecial
        Next varWS
        Application.DisplayAlerts = False
        varWB2.Close
    Next
    Set varFSO = Nothing
    varCurrentRow = 0
    Application.ScreenUpdating = True

End Sub

Function varListFiles(ByVal varPath As String)

    Set varFSO = VBA.CreateObject("Scripting.FileSystemObject")
    Set varOFolder = varFSO.GetFolder(varPath)
    Set varOFiles = varOFolder.Files
    If varOFiles.Count = 0 Then Exit Function
    ReDim varArray(1 To varOFiles.Count)
    varI = 1
    For Each varOFile In varOFiles
        varArray(varI) = varOFile.Name
        varI = varI + 1
    Next

End Function

Hi there! EXCEL MAX
I really appreciate your quick reply
But after running the code, excel went grey out and did not bring and data