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

Dostonus

New Member
Joined
Jul 19, 2020
Messages
7
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
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 Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.

EXCEL MAX

Active Member
Joined
Nov 11, 2020
Messages
392
Office Version
  1. 2016
Platform
  1. Windows
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.

VBA 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

New Member
Joined
Jul 19, 2020
Messages
7
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
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.

VBA 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
 

Watch MrExcel Video

Forum statistics

Threads
1,130,083
Messages
5,639,977
Members
417,120
Latest member
Pavithra devi

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top