Find and Move - Clean up list

A

AlanAnderson

Board Regular
Joined
Jun 7, 2010
Messages
134
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:p></o:p>
In somecases two different contacts aqre separated by one empty row, in others eitherno separating row or various numbers<o:p></o:p>
<o:p> </o:p>
At somepoint I need to enter all this info into an Access database. Before attemptingthat I want to clean it up in Excel.<o:p></o:p>
<o:p> </o:p>
1. Basic Sorting and Moving<o:p></o:p>
<o:p> </o:p>
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:p></o:p>
I startedoff by entering an indicator in each row (H heading, N Name, T Telephonenumbers, e Email address and W for web site<o:p></o:p>
<o:p> </o:p>
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:p></o:p>
<o:p> </o:p>
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:p></o:p>
<o:p> </o:p>
Whilst Ihave Access VBA experience I am unfamiliar with VBA excel.<o:p></o:p>
<o:p> </o:p>
Idesperately need to be pointed in the right direction. Even if I couldautomatically extract 60% it would be a great win.<o:p></o:p>
<o:p> </o:p>
<o:p> </o:p>




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]
Click to expand...



<o:p> </o:p>
Thanks



<o:p> </o:p>
Alan<o:p></o:p>
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
Sort by date Sort by votes
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.

Code: 
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
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,224,824
Messages
6,181,187
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

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