Copying data from multiple files have the same structure

hello members
I'm having difficulty in updating the data.
Database my input includes a lot of the same file structure.
Now I need to copy data from that file into a new file.
Input: company1, Company 2, company3 ....
Output: Company
Can someone help me.
I thank you in advance.

Maybe :

Private Function GetLastRow() As Long
  GetLastRow = Application.Max(Cells(Rows.Count, "C").End(xlUp).Row + 1, 4)
End Function
Sub Test()
  Dim wsMain As Worksheet, lastRow As Long, strFilePattern As String, strDir As String
  Application.ScreenUpdating = False

  strFilePattern = ThisWorkbook.Path & "\Company*.*"

  Set wsMain = ActiveSheet
  Rows("4:" & GetLastRow).Clear
  strDir = Dir(strFilePattern)
  Do While Len(strDir)
     If strDir <> ThisWorkbook.Name Then
        lastRow = GetLastRow
        With Workbooks.Open(ThisWorkbook.Path & "\" & strDir)
          With .Sheets("Sheet1")
            wsMain.Cells(lastRow, "A").Value = .Range("C2").Value
            wsMain.Cells(lastRow, "B").Value = .Range("F2").Value
            .Range("C4").CurrentRegion.Copy
            wsMain.Cells(lastRow, "C").PasteSpecial xlPasteValues
          End With
          Application.DisplayAlerts = False
            .Close
          Application.DisplayAlerts = True
        End With
     End If
     strDir = Dir
  Loop

  Application.ScreenUpdating = True
End Sub

Originally Posted by karedog

Maybe :

Private Function GetLastRow() As Long
  GetLastRow = Application.Max(Cells(Rows.Count, "C").End(xlUp).Row + 1, 4)
End Function
Sub Test()
  Dim wsMain As Worksheet, lastRow As Long, strFilePattern As String, strDir As String
  Application.ScreenUpdating = False

  strFilePattern = ThisWorkbook.Path & "\Company*.*"

  Set wsMain = ActiveSheet
  Rows("4:" & GetLastRow).Clear
  strDir = Dir(strFilePattern)
  Do While Len(strDir)
     If strDir <> ThisWorkbook.Name Then
        lastRow = GetLastRow
        With Workbooks.Open(ThisWorkbook.Path & "\" & strDir)
          With .Sheets("Sheet1")
            wsMain.Cells(lastRow, "A").Value = .Range("C2").Value
            wsMain.Cells(lastRow, "B").Value = .Range("F2").Value
            .Range("C4").CurrentRegion.Copy
            wsMain.Cells(lastRow, "C").PasteSpecial xlPasteValues
          End With
          Application.DisplayAlerts = False
            .Close
          Application.DisplayAlerts = True
        End With
     End If
     strDir = Dir
  Loop

  Application.ScreenUpdating = True
End Sub

Perfect.
Thank Karedog

You are welcome, glad I can help.


Regards