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

sdas34

New Member
Joined
Jan 8, 2021
Messages
8
Office Version
  1. 365
Platform
  1. Windows
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:
ABC
1
2Name:Dr. Anderson
3Designation:Hospital Incharge

Now, I want to create a new excel file where the structure will be like this:
AB
1NameDesignation
2Dr. AndersonHospital Incharge

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

Attachments

  • Data Format.PNG
    Data Format.PNG
    11.7 KB · Views: 25
  • Form 1.PNG
    Form 1.PNG
    19.9 KB · Views: 27
  • Form 2.PNG
    Form 2.PNG
    19.3 KB · Views: 26
  • Form 3.PNG
    Form 3.PNG
    20.4 KB · Views: 25

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
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.


Code:
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
 
Upvote 1

Forum statistics

Threads
1,213,553
Messages
6,114,279
Members
448,562
Latest member
Flashbond

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
Back
Top