Create a macro to extract data
Hi all,
I'd like to create an excel macro to extract information on companies: name, address, ID, phone, etc.
Attached an excel file in which the first tab contains the data. The second tab is showing how the output of the macro should look like with the first two companies in the 'data' tab.
Your help will be very appreciated to solve this issue.
Thanks,
Ali
There is only one name row for First4. For 5th name (row39, row42) there are two names . It is confusing. Pl give expected results for all data in 'data' sheet.
Pl note
Array formula should be confirmed with Ctrl+Shift+Enter keys together.
If answere is satisfactory press * to add reputation.
You're right - some of the companies have two names. The first name is an abbreviation and the second name is the full one. We can ignore the first name and use only the full name.
What is PI?
Some are having 2 Cel numbers . So I have added one more column for Cel.
The headings should be same as in the file.
Range(O1) value is to be : Gérant/ Gérante/ Président/ PCA/ DG . PDG changed to DG as there is no PDG in data
Macro code:
Please Login or Register to view this content.
hi Kvsrinivasamurthy,
That's brilliant! I don't how you did this quickly - I need to learn!
There are a few tweeks to make to the code to fix some issues:
1. The mcro didn't copy the names of the last four companies - it appears like this &-&CC : 7800158N. The CC should be in column D of tab 'wantedSolution'. How can fix this?
2. Address and Tel number merged in column D - but that's OK! I can sort this out with an excel formula
3. Inputs in columns M and N are also merged. Will be good if this can be corrected.
Really appreciate your help on this! This is a super-very good start!
Can you give examples of Address and Tel numbers merged in the file.
Here is the code. Problem 1 is solved.
For problem 2 and 3 give examples in file.Please Login or Register to view this content.
Different method.
Please Login or Register to view this content.
Oh, fantastic. Problem is indeed solved when I run the macro. Find attached a file containing the output after running the macro to show you problem 2 and 3.
Interesting to see that your file has no such issue.
Last edited by alimou; 02-12-2024 at 03:06 PM. Reason: missing attachment
Hi Jindon - thank you for stepping with your alternative solution. really appreciated. It looks very promising.
What do the two lines below mean?
1. Set dic = CreateObject("Scripting.Dictionary")
2. .Pattern = "\b(([A-Z]{2,3}|[A-Z][a-z\u00C0-\u024F -]+)\.? *"
Thanks,
Alimou
1. Dictionary object
Used to get position of unique header in this case.
2. Pattern to match the bold parts(headings) of your data.(Regular Expression)
i.e,
2 or 3 capital letters or 1 capital letter and small letter(s) including accented character(s) followed by a colon.
HTH.
Jindon, you are a star!
Your code appears to work perfectly. You're a life saver. Will run the macro on a bigger set of data. Will get if I need further help. (if you don't mind!)
Thanks,
Alimou
You are welcome,
I've just looked at the result again and found E-mail and E- mail.
This is to combine these two in E-mail.
Please Login or Register to view this content.
Thank you Jindon. Will run the code and check of any issue i may encounter.
Hope it's OK to get in touch, then!
Thanks again
hi Jindon,
I have tried to run the macro after doing some clean up in the data. There is now an error message displaying 'Subscript out of range'. In the attached snapshot, you will see the line causing the error. How to solve this?
Do you have more than 100 headers?
try change
toPlease Login or Register to view this content.
Please Login or Register to view this content.
Thank you Jindon. It worked without an error message.
I will check the output. Once again, thank you so much
Hi Jindon, hope you're well and that you're still following my thread.
I spent a lot of time cleaning up the data on which to run your excel macro. It works well but the output generated has some issues, which are the result of inconsistencies in the original data. For example, the macro creates a table of 46 headers, which is fine BUT there are duplicates. I'm not sure how this can be solved other than cleaning the data. Any idea?
The other issue is that the macro seems to stop after reaching an output of around 4,000 row (names). I believe there should be more companies/names to extract. Are there any limit in the macro for row numbers?
I have attached another file with more data if you'd like to test the macro yourself.Data_Xcel_Forum_4J.xlsx
Try this one .
Please Login or Register to view this content.
The new macro works well, although it was still generating output of no more than 5,000 rows. I found a way around this by splitting the dataset into two tabs (50k rows each) - I was then able to get the macro to extract all infos, working on each tab separately. I'm satisfied with that.
Now my last issue is that the macro skips the companies in instances where there's no empty row between the name and the relevant information. For example, the macro will extract the infos for AFRICAN MARINE EXPERTISES, but not for AGRI-VISION - see below. Any idea for a solution?
AFRICAN MARINE EXPERTISES
CC : 1619107B
Adresse : Cocody II Plateaux Aghien les Perles Cel. : (225)
0787087087 Cel. : (225) 0767846501 E-mail :
[email protected] E-mail : info.ci@cec-
rmb.com Activités : Pêche maritime Gérant : ADE PATRICK
AGRI-VISION
CC : 1650027G Adresse : Plateau-Avenue
Franchet d’Espéret, Imm Fakhry Cel. : (225) 0707510842
Cel. : (225) 0708045092 E-mail : [email protected]
Effectif : 30 Activités : Activités de soutien à l’agriculture
Gérante : COULIBALY GNIGUE AMI
Try this with the big amount of data.
Please Login or Register to view this content.
This macro works brilliantly, solving the issues in my previous messsage. Thank you Jindon
Will now work through the output and do some some clean-up
hi Jindon - this is probably my last issue regarding this macro. Thank you for your help so far. I'm conscious it's sometimes not possible to get a macro to produce a perfect result, particularly when handling lots of data. But I was wondering if you can solve this problem.
When the macro is looping through the data to extract the information, it generates lots of unecessary columns with headers that sometimes are single characters. Do you think it would be possible to tweak the macro to extract only the key information and put everything else in one or two columns at the end of the table. Below is the list of columns that the macro currently generates - I cut the list to the first 50 columns. It goes as much as 300 columns. I'm only interested in the information highlighted. Is that possible?
Name
CC
Adresse
Tél.
Cel.
Activités
Gérante
Effectif
RC
Date de création
Fax
Année de création
Forme juridique
DG
Président
22 52 59 06 / LD)
Site web
tion
PCA
PDG
Général
Délégué
Directeur
PCG
Responsable
Lot
Ilot
Section
Parcelle
Principal
General
Administrateur
Dirigeant
Consultants
Associé
Tel.
Gestion
Directrice
juridique
Financier
Comptable
DAF
Exploitant
Promoteur
Tél
dique
Site internet
L
de création
Cel
Responsable comptable
création
BP
2720209347E-mail
C
Technique
CEL.
Gérantes
Air comprimé
RC.
Yep, that's because header or item are sometimes crossing lines...
try
Please Login or Register to view this content.
Thank you. I tried the new macro and there's a bug on this line, with the Debug functionality highlighted the text in red:
Sub test()
Dim a, e, x, s(1) As String, i As Long, n As Long
Dim txt As String, dic As Object, m As Object
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("data")
.Rows(1).Insert
x = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Value
.Rows(1).Delete
End With
ReDim a(1 To UBound(x) + 2, 1 To 100): n = 1: a(n, 1) = "Name"
With CreateObject("VBScript.RegExp")
.Global = True
For i = 1 To UBound(x, 1)
.Pattern = "^([^:]+?) (CC : .*)"
If .test(x(i, 1)) Then
n = n + 1: a(n, 1) = .Replace(x(i, 1), "$1")
x(i, 1) = .Replace(x(i, 1), "$2")
txt = GetString(x, i)
End If
.Pattern = "\b(([A-Z]{2,3}|[A-Z][a-z\u00C0-\u024F -]+)\.?) *: *(.+?)" & _
"(?=(([A-Z]{2,3}|[A-Z][a-z\u00C0-\u024F -]+)\.? *:|$))"
If x(i, 1) <> "" Then
If (Not .test(x(i, 1))) * (x(i - 1, 1) = "") Then
n = n + 1: a(n, 1) = x(i, 1)
txt = GetString(x, i + 2)
End If
End If
If Len(txt) Then
For Each m In .Execute(txt)
s(0) = Trim$(Replace(m.submatches(0), "-", "")): s(1) = Trim$(m.submatches(2))
If dic.exists(Left$(s(0), Len(s(0)) - 1)) Then s(0) = Left$(s(0), Len(s(0)) - 1)
For Each e In Array("e", "s")
If dic.exists(s(0) & e) Then s(0) = s(0) & e: Exit For
Next
If s(0) Like "*[es]" Then
If dic.exists(Left$(s(0), Len(s(0)) - 1)) Then s(0) = Left$(s(0), Len(s(0)) - 1)
End If
If Not dic.exists(s(0)) Then
dic(s(0)) = dic.Count + 2: a(1, dic.Count + 1) = m.submatches(0)
End If
a(n, dic(s(0))) = a(n, dic(s(0))) & IIf(a(n, dic(s(0))) <> "", " / ", "") & s(1)
Next
txt = ""
End If
Next
End With
With Sheets("result")
.UsedRange.ClearContents
.[a1].Resize(n, dic.Count + 1) = a
.Columns.AutoFit
End With
End Sub
Function GetString(a, s As Long) As String
Dim i As Long, ii As Long
Do While a(s + ii, 1) <> ""
GetString = GetString & a(s + ii, 1)
ii = ii + 1
If UBound(a, 1) < s + ii Then Exit Do
Loop
End Function
Last edited by alimou; 03-24-2024 at 10:56 AM.
It's not a good news...
try
Please Login or Register to view this content.
You're right, it's not good news. There's still a bug, this time the line below is highlighted:
ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) + 100)
If not possible to solve, that will be ok. You've already done a lot!
The last resort...
You will need to refine the list in "MyList" sheet as attached.
Please Login or Register to view this content.
Last edited by jindon; 03-28-2024 at 01:53 AM. Reason: File replaced due to wrong item in the list.
BRAVO!!! This has worked nicely!
Jindon - you're my superstar and I don't know how to thank you for your help. It's really really appreciated.
Jindon - another request, a small one. Certainly easy for you to solve. (I'll understand if you don't have time to help - you've already solved a big problem!)
I'd like a macro to simply remove blank rows in a range - see attached file that shows what I'm after - this is a sample of the data (50k rows in total).
Only for the data presented in #30.
Please Login or Register to view this content.
Problem solved. Thank you Jindon for ALL your help on this!
How do I provide a positive review for your work?
There are currently 1 users browsing this thread. (0 members and 1 guests)
Posting Permissions
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks