Find and Move - Clean up list

[AlanAnderson]

I have inheriteda list of contacts that is in an appalling state. There is almost noconsistency in the layout. In some cases all the info is in one field. Others amix of info, in rare cases properly separated. <o></o>
In somecases two different contacts aqre separated by one empty row, in others eitherno separating row or various numbers<o></o>
<o> </o>
At somepoint I need to enter all this info into an Access database. Before attemptingthat I want to clean it up in Excel.<o></o>
<o> </o>
1. Basic Sorting and Moving<o></o>
<o> </o>
In simpleterms I would like to place the name in one column, telephone numbers in thenext, email address in next, website in the following<o></o>
I startedoff by entering an indicator in each row (H heading, N Name, T Telephonenumbers, e Email address and W for web site<o></o>
<o> </o>
As thereare some 6000 lines in the actual file this will take forever just to enterthese indicators. After that I will need to clean up almost every line<o></o>
<o> </o>
2. Is there a smart way to go througheach field and identify and move the different elements into different columns(E.g. Telephones, Names, Addresses etc)<o></o>
<o> </o>
Whilst Ihave Access VBA experience I am unfamiliar with VBA excel.<o></o>
<o> </o>
Idesperately need to be pointed in the right direction. Even if I couldautomatically extract 60% it would be a great win.<o></o>
<o> </o>
<o> </o>




A shortsample file is enclosed (all data has been “anonomised” WHOOPS - I cant attach it. I have pasted a selection below. Column B contains the "h", "n", T" etc
All the rest is in column C

[TABLE="width: 523"]
<tbody>[TR]
[TD]h[/TD]
[TD]HEALTH Care[/TD]
[/TR]
[TR]
[TD][/TD]
[TD] [/TD]
[/TR]
[TR]
[TD][/TD]
[TD]HOSPITALS - Thyolo[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]BlahHospital, Makwasa,[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Tel: 01 666 666 / 667[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]email: enquiries@blahhospital.org,[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]www.blahhospital.org[/TD]
[/TR]
[TR]
[TD][/TD]
[TD] [/TD]
[/TR]
[TR]
[TD][/TD]
[TD]HOSPITALS - Zomba[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]BlahHealth Clinic,[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Tel: 0111 666 666, 0888 666 666[/TD]
[/TR]
[TR]
[TD][/TD]
[TD] OPTICIANS AND VETS[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]BlahOpticals - Blantyre: Wadda wadda Shopping Mall,[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Tel: 01 666 666 / 667[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]email: blahi@wadda.com[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Blah House, Tel: 01 666 666[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]email: blah2@wadda.com.[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]n[/TD]
[TD] Eye Clinic - Blantyre: Dr. Jane Doe, [/TD]
[/TR]
[TR]
[TD]t[/TD]
[TD] Tel: 01 666 666, 099 666 666, email: director@blahi.org,[/TD]
[/TR]
[TR]
[TD]e[/TD]
[TD] email: director@blah.org,[/TD]
[/TR]
[TR]
[TD]w[/TD]
[TD]www.blah.org. Lilongwe, Tel: 01 666 666[/TD]
[/TR]
[TR]
[TD]a[/TD]
[TD]Salima[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]t[/TD]
[TD]Tel: 0994 079 507[/TD]
[/TR]
[TR]
[TD][/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]n[/TD]
[TD]Blah Optical Centre, [/TD]
[/TR]
[TR]
[TD]a[/TD]
[TD]Nkhotakota, Blah Hospital[/TD]
[/TR]
[TR]
[TD]t[/TD]
[TD]Tel: 0994 666 666, 01 666 666[/TD]
[/TR]
[TR]
[TD]e[/TD]
[TD]email: blahl@gmail.com[/TD]
[/TR]
[TR]
[TD][/TD]
[TD] [/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Blah - Blantyre: Blah blah blah Hospital, Glyn Jones Rd, Tel:01 666 931,[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]0995 666 666. Lilongwe: Blah bah Health Centre, Presidential Way,[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Tel: 0999 666 666 Mzuzu: Mzuzu central hospital, Tel: 01 666 666, 0995 666 666[/TD]
[/TR]
[TR]
[TD][/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]h[/TD]
[TD]VETERINARY[/TD]
[/TR]
[TR]
[TD]n[/TD]
[TD]blah blah vet, Area 9, Llw,[/TD]
[/TR]
[TR]
[TD]t[/TD]
[TD]Tel: 01 666 666, 0994 666 666[/TD]
[/TR]
[TR]
[TD]e[/TD]
[TD]email: info@blahvert.org,[/TD]
[/TR]
[TR]
[TD]w[/TD]
[TD]www.blahvet.org[/TD]
[/TR]
[TR]
[TD][/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]n[/TD]
[TD]bhlah Vet Clinic, Area 3, Lilongwe,[/TD]
[/TR]
[TR]
[TD]t[/TD]
[TD]Tel: 01666 666, 0999 666 666[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]YaddaYadda Vet Clinic, Area 3, Llw, Tel: 01 666 666[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]0888 666 666, 0991 666 666[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Blah Animal Clinic, Kanengo, Tel: 0995 666 666, Emergency: 0111 666 666, info@blahcare.org[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]www.blahcare.org[/TD]
[/TR]
[TR]
[TD][/TD]
[TD] [/TD]
[/TR]
[TR]
[TD][/TD]
[TD]blahi Veterinary Surgery, [/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Tel 01 666 666, 0999 666 666/ 0995 666 666[/TD]
[/TR]
[TR]
[TD][/TD]
[TD] [/TD]
[/TR]
[TR]
[TD][/TD]
[TD]The Blah Clinic, Cnr Blahs and Yadda Rd, Blantyre, Tel: 01 666 666(office), 0111 666 666/7 (home), 0999 666 666 / 0888 8666 666[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody><colgroup><col><col></colgroup>[/TABLE]

<o> </o>
Thanks



<o> </o>
Alan<o></o>

 

[pbornemeier]

You describe a horrible task that many have had to undertake. This code will help, but the resulting data will have to be thoroughly reviewed.

The following code will copy each column C cell to appropriate columns in the same row, based on coded criteria. If a cell meets no criteria for copying it is copied to column I.

I expect you will have to edit the current code.

After it is run the first time, review the columns to see what additional criteria can be added to reduce the number of "bad" column selections.
Clear columns D and over and run code again
Repeat these steps as necessary

Once the "bad" selections are minimized, review all rows to figure out which cells need to be edited
-- to remove surplus data for that column
-- to split entries into another record
-- and to determine which rows should be grouped into a single row (record). Use the next unused column to indicate the start of a record with a # (any symbol will do).

Additional code could be developed to combine all rows on or after a header symbol and before the next header symbol to a single row.

Option Explicit

Sub SplitHideousContactList()

    'Assumption: Data Starts in Row 2
    'Assumption: Col B contains nothing or single letter (hntew)
    'Assumption: Col C contains Text to be evaluated

    Dim lLastRow As Long
    Dim lRowIndex As Long
    
    Const lColHead As Long = 4
    Const lColName As Long = 5
    Const lColPhone As Long = 6
    Const lColEmail As Long = 7
    Const lColWeb As Long = 8
    Const lColNone As Long = 9
    
    Dim lCol As Long
    
    Dim aryWeb As Variant
    Dim aryEMail As Variant
    
    Dim lAryIndex As Long
    
    aryWeb = Array("WWW.", "HTTP:", ".ORG", ".COM", "WEB:")
    aryEMail = Array("@", "EMAIL:")
    
    lLastRow = Cells(Rows.Count, 3).End(xlUp).Row
    
    Range("E1").Resize(1, 5).Value = Array("Name", "Telephone", "Email", "Web", "Not Copied to Other")

    For lRowIndex = 2 To lLastRow
        lCol = 0
        'Copy the ones you checked - Check Col B
        lCol = InStr("...HNTEW", UCase(Cells(lRowIndex, 2).Value))
        If lCol > 3 Then Cells(lRowIndex, 3).Copy Destination:=Cells(lRowIndex, lCol)
        lCol = 0
        
        'Check for Tel:
        If InStr(UCase(Cells(lRowIndex, 3).Value), "TEL:") > 0 Then
            lCol = lColPhone
            Cells(lRowIndex, 3).Copy Destination:=Cells(lRowIndex, lCol)
        End If
    
        'Check for email:
        For lAryIndex = LBound(aryEMail) To UBound(aryEMail)
            If InStr(UCase(Cells(lRowIndex, 3).Value), aryEMail(lAryIndex)) > 0 Then
                lCol = lColEmail
                Cells(lRowIndex, 3).Copy Destination:=Cells(lRowIndex, lCol)
            End If
        Next
        
        'Check for web
        For lAryIndex = LBound(aryWeb) To UBound(aryWeb)
            If InStr(UCase(Cells(lRowIndex, 3).Value), aryWeb(lAryIndex)) > 0 Then
                lCol = lColWeb
                Cells(lRowIndex, 3).Copy Destination:=Cells(lRowIndex, lCol)
                Exit For
            End If
        Next
        
        'Check for phone
        If Cells(lRowIndex, 3).Value Like "*## ### ###*" Then
            lCol = lColPhone
            Cells(lRowIndex, 3).Copy Destination:=Cells(lRowIndex, lCol)
        End If
        
        If lCol = 0 Then
            lCol = lColNone
            Cells(lRowIndex, 3).Copy Destination:=Cells(lRowIndex, lCol)
        End If
    Next
End Sub