VBA Macro - Copy data from single column (from multiple excelfiles) and paste without blank cells in data acquisition workbook

[DEBOER]

Hello All, this is my first post and I am wondering how quick I will get a useful solution for my VBA newbie problem.

I want to copy data from a single column which has the following location "F9:F26283", the data is to be retrieved from approximately 100 excelfiles with the same tab/sheet name "ReportHeader".
Additionally the data in the column is separated by blank cells (see screenshot), as soon as the data is to be pasted into the data acquisition workbook I would like to have no blank cells between my (value) data.

I am looking for a macro that can do the above by going through the excelfiles by opening-retrieving data-paste data-closing. The filenames can be attained through a macro button that runs the code stated below

The separate excelfiles have different filenames, however scavenging from an older macro I used I am able to retrieve all the filenames from a single folder by using this macro, this data can then be fed into macro as requested above:
EXISTING MACRO "GET FILENAMES FROM FOLDER"
Private Sub CommandButton1_Click()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer

'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
A = Cells(2, 2).Value
Set objFolder = objFSO.GetFolder(A)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
Cells(i + 4, 1) = objFile.Name
'print file path
Cells(i + 4, 2) = objFile.Path
'print last modified date
Cells(i + 4, 3) = objFile.DateLastModified
i = i + 1
Next objFile
End Sub

Please help, thanks a lot in advance! I am curious how fast I would get an useful solution to this newbie problem I have

Regards,
DEBOER

 

[DEBOER]

@DanteAmor - Might this be an easy to solve question for you?

 

[DanteAmor]

A = Cells(2, 2).Value

I see in your macro that you take the folder from cell B2. My macro is also going to take the folder from cell B2, but from Sheet1. On the same Sheet1 in column F the results will remain.

Try the following:

Sub CopyLastRow_ToMaster()
  Dim fso As Object, fldr As Object, fName As Object
  Dim filePath As String, sheetName As String
  Dim sh1 As Worksheet
  Dim wb2 As Workbook
  Dim i As Long, n As Long
  Dim ary() As Variant

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  '************
  'Adjust the following with your data.
  '************
  Set sh1 = ThisWorkbook.Sheets("Sheet1")     'Sheet to put the result.
  filePath = sh1.Range("B2")                  'Folder with the files.
  sheetName = "ReportHeader"                  'The name of the sheet with the data.

  Set fso = CreateObject("scripting.filesystemobject")
  Set fldr = fso.GetFolder(filePath)
  
  sh1.Range("F:F").ClearContents
  For Each fName In fldr.Files
    If fName.Name Like "*.xls*" Then
      If HasSheet(filePath, fName.Name, sheetName) Then
        Set wb2 = Workbooks.Open(fName, , True)
        With wb2.Sheets(sheetName)
          For i = 1 To .Range("F" & Rows.Count).End(3).Row
            If .Range("F" & i).Value <> "" Then
              n = n + 1
              ReDim Preserve ary(1 To n)
              ary(n) = .Range("F" & i).Value
            End If
          Next
        End With
        wb2.Close False
      End If
    End If
  Next
  If n > 0 Then sh1.Range("F1").Resize(n).Value = Application.Transpose(ary)
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

 

[DEBOER]

Hello DanteAmor, Thanks for reaching out. I set up a workbook with Sheet1 in which Cell B2 states the folderpath, I put your code into a Module, connected a button to it to run the code.
However it gets stuck at "HasSheet" with the following error. Any idea why it's getting stuck?

 

[Alex Blakenburg]

However it gets stuck at "HasSheet" with the following error. Any idea why it's getting stuck?

@DanteAmor has a function he normally includes but he must just have missed it this time.
Add this code after your end sub.

Function HasSheet(fPath As String, fName As String, sheetName As String)
  Dim f As String
  f = "'" & fPath & "[" & fName & "]" & sheetName & "'!R1C1"
  HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
End Function

 

[DanteAmor]

However it gets stuck at "HasSheet" with the following error. Any idea why it's getting stuck?

Sorry for that, I forgot to put the function HasSheet.
This is the complete code, put all the code in the module and run the CopyLastRow_ToMaster macro

Sub CopyLastRow_ToMaster() 
  Dim fso As Object, fldr As Object, fName As Object
  Dim filePath As String, sheetName As String
  Dim sh1 As Worksheet
  Dim wb2 As Workbook
  Dim I As Long, n As Long
  Dim ary() As Variant

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  '************
  'Adjust the following with your data.
  '************
  Set sh1 = ThisWorkbook.Sheets("Sheet1")     'Sheet to put the result.
  filePath = sh1.Range("B2")                  'Folder with the files.
  sheetName = "ReportHeader"                  'The name of the sheet with the data.

  Set fso = CreateObject("scripting.filesystemobject")
  Set fldr = fso.GetFolder(filePath)
  
  sh1.Range("F:F").ClearContents
  For Each fName In fldr.Files
    If fName.Name Like "*.xls*" Then
      If HasSheet(filePath, fName.Name, sheetName) Then
        Set wb2 = Workbooks.Open(fName, , True)
        With wb2.Sheets(sheetName)
          For I = 1 To .Range("F" & Rows.Count).End(3).Row
            If .Range("F" & I).Value <> "" Then
              n = n + 1
              ReDim Preserve ary(1 To n)
              ary(n) = .Range("F" & I).Value
            End If
          Next
        End With
        wb2.Close False
      End If
    End If
  Next
  If n > 0 Then sh1.Range("F1").Resize(n).Value = Application.Transpose(ary)
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Function HasSheet(fPath As String, fName As String, sheetName As String)
  Dim f As String
  f = "'" & fPath & "\[" & fName & "]" & sheetName & "'!R1C1"
  HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
End Function