Copy excel entries into new work sheet and rearrange the values

[KokoroAyo]

I need help on an assignment. Its a list of patients meant for healthcare purposes. This list is sent to us in PDF format and we just search to find any entitled patient on the list. Now we have to convert to excel and rearrange for better management. My task now is to handle the rearrangement using macro since rearranging all manualy takes weeks and we receive the list on monthly basis.

I have never done this before and I am lost as to how to handle it. Please help.

Below is the format of the list. It is arranged in Header - List format but we need it in a different format as shown in the Sample Output format.

Sample List (with Little Explanation
1. Rows like 26645 are headers (there are footers also) and will be automatically removed
2. Hospital No (First part of Row 26646) is Unique to each Hospital). I will form a new field
3. Hospital Name Will form a new field or will be ignored
4. Row 26647 carries Family ID and Family Name. Asterisks will be removed to get the Number
5. Row 26648 Shows details of Family Head (Proncipal). Unique Id will be FamilyId + 0. That is 027926670. It forms a Unique Field
6. Principal/Spouse/Child is the Membership in the Family - hence it forms a field
7. Family Name forms a Field
8. Field B is First Name
9. Field C contains Date of Birth and Gender. This will be broken down to separate fields. Last Part of the string can be ignored (it is Batch Number)

Embedded Broken Image removed

Sample from the Original Excel Sheet

Ronsberger Nigeria Ltd.		Issued by NHIS
	OY/0250 Catholic Hospital, Oluyoro - Oluyoro, Ibadan, Oyo State
*02792267* SANUSI
0 Principal SANUSI	TEMILADE	02/11/1980 M E/240
1 Spouse SANUSI	OLUWADAMILOLA 19/03/1992 F E/240
*02792269* OKOLO
0 Principal OKOLO	EMMANUEL 23/10/1980 M E/240
2 Child1 OKOLO	CHUKWUEMEKA 13/06/2015 M E/240
3 Child2 OKOLO	UZOAMAKA 03/05/2013 F E/240
*02792277* AWOLOLA
0 Principal AWOLOLA	AJIBOLA	10/08/1977 M E/240
1 Spouse AWOLOLA	ABIDEMI	05/08/1982 F E/240
2 Child1 AWOLOLA	MORAYOOLUWA 20/06/2012 F E/240
*02792285* AGBABIAJE
0 Principal AGBABIAJE	TOLULOPE	26/07/1985 M E/240
*02792353* ODUGBEMI
0 Principal ODUGBEMI	RAFIU	13/02/1981 M E/240
1 Spouse ODUGBEMI	TOYIN	04/08/1990 F E/240
2 Child1 ODUGBEMI	OLAMIDE	25/07/2012 F E/240
3 Child2 ODUGBEMI	EMMANUEL 10/10/2006 M E/240
*02839471* ADEJIMI
0 Principal ADEJIMI	ADEKUNLE 28/06/1978 M E/344
1 Spouse ADEJIMI	OLUBUNMI 14/07/1979 F E/344
2 Child1 ADEJIMI	OLUWADABIRA 08/07/2007 M E/344

<tbody>
</tbody>

Sample Expected Output

SN (Serial Number - Autogenerated)	CLIENT_NUMBER (HEADNUMBER without the '*' + UNIT NUMBER AS IN DOCUMENT) - PLEASE TAKE NOTE OF LEADING ZEROS	SURNAME (FAMILY NAME AS IN DOCCUMENT)	FIRST_NAME (AS IN DOCUMENT)	DATE_OF_BIRTH (AS IN DOCUMENT)	GENDA (AS IN DOCUMENT)	FAMILY_MEMBERSHIP (AS INDICATED IN DOCUMENT) - Options are: Principal, Spouse and Child	HOSPITAL_NAME (COPY HEADER HOSPITAL NAME FOR ALL CLIENTS FOUND UNDER IT)	HOSPITAL_ID (COPY CORRESPONDING HEADER HOSPITAL ID FOR ALL CLIENTS FOUND UNDER IT)
See Examples Below
1	027922670	SANUSI	TEMILADE	02/11/1980	M	Principal	Catholic Hospital, Oluyoro - Oluyoro, Ibadan, Oyo State	OY/0250
2	027922671	SANUSI	OLUWADAMILOLA	19/03/1992	F	Spouse	Catholic Hospital, Oluyoro - Oluyoro, Ibadan, Oyo State	OY/0250
3	027922690	OKOLO	EMMANUEL	23/10/1980	M	Principal	Catholic Hospital, Oluyoro - Oluyoro, Ibadan, Oyo State	OY/0250
4	027922691	OKOLO	CHUKWUEMEKA	13/06/2015	M	Child	Catholic Hospital, Oluyoro - Oluyoro, Ibadan, Oyo State	OY/0250
5	027922692	OKOLO	UZOAMAKA	03/05/2013	F	Child	Catholic Hospital, Oluyoro - Oluyoro, Ibadan, Oyo State	OY/0250
6	027922770	AWOLOLA	AJIBOLA	10/08/1977	M	Principal	Catholic Hospital, Oluyoro - Oluyoro, Ibadan, Oyo State	OY/0250
7	027922771	AWOLOLA	ABIDEMI	05/08/1982	F	Spouse	Catholic Hospital, Oluyoro - Oluyoro, Ibadan, Oyo State	OY/0250
8	027922772	AWOLOLA	MORAYOOLUWA	20/06/2012	F	Child	Catholic Hospital, Oluyoro - Oluyoro, Ibadan, Oyo State	OY/0250

<tbody>
</tbody>

My major problem is the rearrangement of this data.
If required, I can upload a sample workbook if there is an avenue for uploading file, or I can put it in a place and share the link.

Thanks in advance.

 

[MickG]

I think you need to supply some details of what your trying to achieve.!!
Its not very clear.

 

[KokoroAyo]

I think you need to supply some details of what your trying to achieve.!!
Its not very clear.

I Thank you again Mick. Im sorry I didnt reply sooner. I have been on the road. What I want to achieve is exactly the arrangement you have succeeded in helping out with.

Unfortunately, if you look at the initial table uploaded earlier, it was just a small segment from the whole document hence your solution did the magic based on the static address of the first entry (hospital Number and Hospital name).

I tried to run it through the rest of the document which I sent through Box dot com but I could not get the loop right since I was unable to properly identify the cell addresses through a loop.

I want to iterate through the entire list and be able to do exactly what was achieved through your solution. That is my challenge.

Thank you for your help all along.

 

[MickG]

Both of the sheets you sent are of similar format , which of the sheets do you want me to use, "Sheet1" or "Input Format" ????

Sheet1 has no Hospital Names/Headers until row 1446 and different data up to that point and sheet "Input format" has not got a Hospital Name/Header in the first row. How would you like that to be resolved ????

 

[KokoroAyo]

Sheet to use is Input Format

Sheet 1 is the begining of the document. What I always do is to remove all the preables and statistics (that appear on sheet1) from the top, then commence work on the main part of it. Please delete the first set of records at the begining of Input format so that the row Carrying Hospital Name appears top.

Once I get this I can try to adapt it to subsequent reports.

Thank you.

 

[MickG]

Try this for results on sheet2.
NB:- Some of your data on sheet "Input Forum" is not in the correct columns and need adjusting !!!!
NB:- I have removed the first batch of data (No Hospital address) and cell "A1" now contains the first appearance in column "A" of the Words:- "Ronsberger Nigeria Ltd"

.

<tbody>
</tbody>

[COLOR=navy]Sub[/COLOR] MG15Sep13
'[COLOR=green][B]Forum Code:-[/B][/COLOR]
[COLOR=navy]Dim[/COLOR] Sp [COLOR=navy]As[/COLOR] Variant, Hd1 [COLOR=navy]As[/COLOR] [COLOR=navy]String,[/COLOR] Hd2 [COLOR=navy]As[/COLOR] [COLOR=navy]String,[/COLOR] K [COLOR=navy]As[/COLOR] Variant, R [COLOR=navy]As[/COLOR] Variant, c [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Num [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] Ray [COLOR=navy]As[/COLOR] Variant, nSp [COLOR=navy]As[/COLOR] Variant, Q [COLOR=navy]As[/COLOR] Variant, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] p [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Dt [COLOR=navy]As[/COLOR] Date, Aph [COLOR=navy]As[/COLOR] [COLOR=navy]String,[/COLOR] Aphn [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] nStr [COLOR=navy]As[/COLOR] [COLOR=navy]String,[/COLOR] G [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
Ray = Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, 3)
ReDim nRay(1 To UBound(Ray, 1) + 1, 1 To 9)
 nRay(1, 1) = "Ser Num": nRay(1, 2) = "CLIENT_NUMBER": nRay(1, 3) = "Surname": nRay(1, 4) = "First Name": nRay(1, 5) = "DATE_OF_BIRTH": nRay(1, 6) = "GENDA": nRay(1, 7) = "FAMILY_MEMBERSHIP": nRay(1, 8) = "HOSPITAL_NAME": nRay(1, 9) = "HOSPITAL_ID"
c = 1
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=navy]For[/COLOR] n = 1 To UBound(Ray, 1)
   [COLOR=navy]If[/COLOR] Ray(n, 1) = "Ronsberger Nigeria Ltd." [COLOR=navy]Then[/COLOR]
           [COLOR=navy]Select[/COLOR] [COLOR=navy]Case[/COLOR] True
               [COLOR=navy]Case[/COLOR] Not IsEmpty(Ray(n + 1, 1)): Sp = Split(Ray(n + 1, 1), " "): Hd1 = Sp(0): Hd2 = Mid(Ray(n + 1, 1), Len(Sp(0)) + 2)
               [COLOR=navy]Case[/COLOR] Not IsEmpty(Ray(n + 1, 2)): Sp = Split(Ray(n + 1, 2), " "): Hd1 = Sp(0): Hd2 = Mid(Ray(n + 1, 2), Len(Sp(0)) + 2)
               [COLOR=navy]Case[/COLOR] Not IsEmpty(Ray(n + 1, 3)): Sp = Split(Ray(n + 1, 3), " "): Hd1 = Sp(0): Hd2 = Mid(Ray(n + 1, 3), Len(Sp(0)) + 2)
            [COLOR=navy]End[/COLOR] Select
   [COLOR=navy]End[/COLOR] If
    [COLOR=navy]If[/COLOR] Left(Ray(n, 1), 1) = "*" Or IsNumeric(Left(Ray(n, 1), 1)) [COLOR=navy]Then[/COLOR]
            Sp = Split(Ray(n, 1), " ")
        [COLOR=navy]If[/COLOR] Not .Exists(Sp(UBound(Sp)) & "_" & Hd1) [COLOR=navy]Then[/COLOR]
            .Add Sp(UBound(Sp)) & "_" & Hd1, Array(n, Hd1, Hd2)
        [COLOR=navy]Else[/COLOR]
            Q = .Item(Sp(UBound(Sp)) & "_" & Hd1)
                Q(0) = Q(0) & ", " & n
            .Item(Sp(UBound(Sp)) & "_" & Hd1) = Q
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] n
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
        Dt = "1/1/1900": Aph = "": nStr = ""
        Sp = Split(.Item(K)(0), ", ")
          [COLOR=navy]For[/COLOR] n = 0 To UBound(Sp)
            [COLOR=navy]If[/COLOR] InStr(Ray(Sp(n), 1), "*") <> 0 [COLOR=navy]Then[/COLOR]
                Num = Replace(Split(Ray(Sp(n), 1), " ")(0), "*", "")
            [COLOR=navy]Else[/COLOR]
               
               nSp = Split(Trim(Ray(Sp(n), 2) & " " & Ray(Sp(n), 3)), " ")
               [COLOR=navy]If[/COLOR] UBound(nSp) > 0 [COLOR=navy]Then[/COLOR]
                    [COLOR=navy]If[/COLOR] IsDate(nSp(0)) [COLOR=navy]Then[/COLOR]
                        Dt = nSp(0)
                        Aph = nSp(1)
                    [COLOR=navy]ElseIf[/COLOR] IsDate(nSp(1)) [COLOR=navy]Then[/COLOR]
                        nStr = nSp(0)
                        Dt = nSp(1)
                        Aph = nSp(2)
                    [COLOR=navy]End[/COLOR] If
                    c = c + 1
                    nRay(c, 1) = c - 1
                    nRay(c, 2) = Num & Val(Split(Ray(Sp(n), 1), " ")(0))
                    nRay(c, 3) = Split(K, "_")(0)
                    nRay(c, 4) = nStr
                    nRay(c, 5) = CDate(Dt)
                    nRay(c, 6) = Aph
                    nRay(c, 7) = Split(Ray(Sp(n), 1), " ")(1) 
                    nRay(c, 8) = .Item(K)(2)
                 nRay(c, 9) = .Item(K)(1)
            [COLOR=navy]End[/COLOR] If
         [COLOR=navy]End[/COLOR] If
        [COLOR=navy]Next[/COLOR] n
[COLOR=navy]Next[/COLOR] K
[COLOR=navy]End[/COLOR] With
[COLOR=navy]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 9)
    .Value = nRay
    .Columns.AutoFit
    .Borders.Weight = 2
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[KokoroAyo]

Thank you very much Mick. I am really greatful for this noble endeavour. It worked just as I needed it.
And to all MrExcel team. Thank you too.

KokoroAyo.

 

[KokoroAyo]

Hi Mick,

I write to sincerely express my gratitude to you for taking the pain to help me out with the solution to my age long problem.

With this solution I can now deliver my routine responsibility within time line.

Now I am looking at porting the solution to a small VB6 application with a simple user interface so that even when I am not around, someone can just run the application over the new list and get the result.

Please does this forum have a donation portal? I think its worth someone donating something so that other persons can enjoy the kind of support I have just enjoyed.

If yes, please let me have the details so I can make a token donation.

Mick, if you have any project that requires donation, can I also have it sent to me by PM?

Thank you once again.