Extract data from multiple excel files' specific cells and make a new structured output file

[sdas34]

Hi, I have 1000s of .xlsx files where data is not in tabular format. Instead data are in a form structure. There are some merged cells as well. All files' format and sheet name are same. I would like to fetch those data from those excel files' specific cells and paste in a new file under designated columns. And each time the macro will run it should not delete the old record. It should only append the data below.

Form structure:

	A	B	C
1
2	Name:	Dr. Anderson
3		Designation:	Hospital Incharge

Now, I want to create a new excel file where the structure will be like this:

	A	B
1	Name	Designation
2	Dr. Anderson	Hospital Incharge

I have attached few sample files' images and the desired format file's image for your reference. I'd appreciate your help.

 

[ranman256]

paste code below into a module.
set the folder you want to scan in cell: B3
put a button on the sheet to run macro: CollectData
it will open all files in said folder and collect the data.

Option Explicit
Public wbTarg As Workbook, wbSrc As Workbook
Public gcolCity As Collection

Sub CollectData()
Dim vDir
Dim ws As Worksheet
On Error Resume Next
Set gcolCity = New Collection
Set wbTarg = ActiveWorkbook
SetWarnings False
Sheets("Results").Delete
vDir = Range("B3").Value
Sheets.Add
ActiveSheet.Name = "Results"
Set ws = ActiveSheet
'----headers
Range("A1").Value = "CUSTOMER ID"
Range("B1").Value = "NAME"
Range("c1").Value = "CITY"
Range("d1").Value = "NEW YORK"
Range("e1").Value = "CHICAGO"
Range("f1").Value = "WASHINGTON"
Range("g1").Value = "CALIFORNIA"
Range("h1").Value = "PURCHASE AMT"
gcolCity.Add Range("d1").Value
gcolCity.Add Range("e1").Value
gcolCity.Add Range("f1").Value
gcolCity.Add Range("g1").Value
Range("A2").Select
ScanAllFilesInDir vDir
wbTarg.Save
SetWarnings True
MsgBox "Done"
Set ws = Nothing
Set wbSrc = Nothing
Set wbTarg = Nothing
Set gcolCity = Nothing
End Sub


Private Sub ScanAllFilesInDir(ByVal pvDir)
Dim vFil, vTargT
Dim i As Integer
Dim sSql As String
Dim fso
Dim oFolder, oFile
On Error GoTo errImp
If Right(pvDir, 1) <> "\" Then pvDir = pvDir & "\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder(pvDir)
For Each oFile In oFolder.Files
     If InStr(oFile.Name, ".xls") > 0 Then      'ONLY DO EXCEL FILES
           'import the vFile
        Process1File oFile
    End If
Next
Set fso = Nothing
Set oFile = Nothing
Set oFolder = Nothing
Exit Sub
errImp:
MsgBox Err.Description, vbCritical, "clsImport:ImportData()" & Err
Exit Sub
Resume
End Sub


Private Sub Process1File(ByVal pvFile)
Dim vID, vName, vCity, vAmt, vSite, vVal
Dim colSites As New Collection
Dim colVals As New Collection
Dim i As Integer
On Error GoTo errProc
Workbooks.Open pvFile
Set wbSrc = ActiveWorkbook
vID = Range("C3").Value
vName = Range("c4").Value
vCity = Range("C5").Value
vAmt = Range("H3").Value
Range("b7").Select
While ActiveCell.Value <> ""
   vSite = ActiveCell.Value
   vVal = ActiveCell.Offset(1, 0).Value
   colSites.Add vSite, vSite
   colVals.Add vVal, vSite
   ActiveCell.Offset(0, 1).Select  'next col
Wend
ActiveWorkbook.Close False
'---- post result
wbTarg.Activate
ActiveCell.Offset(0, 0).Value = vID
ActiveCell.Offset(0, 1).Value = vName
ActiveCell.Offset(0, 2).Value = vCity
ActiveCell.Offset(0, 7).Value = vAmt
'---post city data
For i = 1 To gcolCity.Count
  vSite = ""
  vCity = gcolCity(i)
  vSite = colSites(vCity)
 
  If vSite = vCity Then
     ActiveCell.Offset(0, i + 2).Value = colVals(vSite)
  End If
Next
ActiveCell.Offset(1, 0).Select    'next row
Set colSites = Nothing
Set colVals = Nothing
Exit Sub
errProc:
MsgBox Err.Description, , Err
Exit Sub
Resume
End Sub


Private Sub SetWarnings(ByVal pbOn As Boolean)
   Application.DisplayAlerts = pbOn    'turn off sheet compatability msg
   Application.EnableEvents = pbOn
   Application.ScreenUpdating = pbOn
End Sub