Tidying a list of records into a database

[jlight]

Hi I've got lots of data in Column A as below (2000 records), and i've been trying to write a macro which will put it into a neat database with field headings name, address 1,2,3,4,5 Postcode and telephone no. My problem is i'm no good at loops or if statements within a macro so i'm defeated. The addresses are different sizes and i need it to recognize postcodes and telephone numbers. There is also some unrequired data. There is always a blank cell after sex and the end of the address before the next record. Thanks for your help.

Joe Bloggs
Reg. no: 00123
Date of Registration: 21/01/2000
Sex: M

1 The Street
Chester-Le-Street
County Durham
DH1 1PP
Tel: 01910000001

Sam Smith
Reg. no: 00050
Date of Registration: 19/07/1999
Sex: M

London Chiropractic Clinic
3 The Mews
London
Greater London
UK
NW0 1AA
Tel: 02087733345

Jack James

 

[Barrie Davidson]

Does this code work okay for you?

Option Explicit

Sub CreateDatabase()
'Written by Barrie Davidson
Dim Dbws As Worksheet
Dim DataRange As Range, CopyRange As Range
Dim PasteRange As Range, TelRange As Range
Dim PostCodeRange As Range
Dim i As Integer, i2 As Integer

Set DataRange = ActiveSheet.UsedRange 'get the data range
Set CopyRange = Range("A1") 'first thing being copied
Sheets.Add after:=CopyRange.Worksheet 'create a new worksheet
Set PasteRange = Range("A2") 'where I'm copying the first piece of data

'Headers
Range("A1").Value = "Name"
Range("B1").Value = "Reg. No"
Range("C1").Value = "Date of Reg"
Range("D1").Value = "Sex"
Range("E1").Value = "Addr1"
Range("F1").Value = "Addr2"
Range("G1").Value = "Addr3"
Range("H1").Value = "Postal Code"
Range("I1").Value = "Tel"

'copying the data
Do While CopyRange.Row < DataRange.Rows.Count
    'Name, reg no, date, and sex
    CopyRange.Copy Destination:=PasteRange
    PasteRange.Offset(, 1).NumberFormat = "@"
    PasteRange.Offset(, 1) = Right(CopyRange.Offset(1), _
        Len(CopyRange.Offset(1)) - InStr(CopyRange.Offset(1), ":") - 1)
    PasteRange.Offset(, 2).NumberFormat = "dd/mm/yyyy"
    PasteRange.Offset(, 2) = CDate(Right(CopyRange.Offset(2), _
        Len(CopyRange.Offset(2)) - InStr(CopyRange.Offset(2), ":") - 1))
    PasteRange.Offset(, 3).NumberFormat = "@"
    PasteRange.Offset(, 3) = Right(CopyRange.Offset(3), _
        Len(CopyRange.Offset(3)) - InStr(CopyRange.Offset(3), ":") - 1)
    
    'Address, telephone
    Set CopyRange = CopyRange.Offset(5)
    i = 0 'initialize variables
    i2 = 0 'initialize variables
    Do While Left(CopyRange.Offset(i), 3) <> "Tel"
        i = i + 1
    Loop
    Set TelRange = CopyRange.Offset(i) 'telephone number
    Set PostCodeRange = TelRange.Offset(-1) 'postal code
    If i - 2 > 2 Then
        'More than 3 address lines
        PasteRange.Offset(, 4) = CopyRange
        PasteRange.Offset(, 5) = CopyRange.Offset(1)
        PasteRange.Offset(, 6) = CopyRange.Offset(2)
        For i2 = 3 To i - 2
            PasteRange.Offset(, 6) = PasteRange.Offset(, 6) & "," & CopyRange.Offset(i2)
        Next i2
    Else
        '3 or less address lines
        For i2 = 0 To i - 2
            PasteRange.Offset(, 4 + i2) = CopyRange.Offset(i2)
        Next i2
    End If
    PasteRange.Offset(, 7) = PostCodeRange 'postal code
    PasteRange.Offset(, 8).NumberFormat = "@"
    PasteRange.Offset(, 8) = Right(TelRange, _
        Len(TelRange) - InStr(TelRange, ":") - 1) 'telephone number
    Set CopyRange = TelRange.Offset(2) 're-setting the copy range
    Set PasteRange = PasteRange.Offset(1) 're-setting the paste range
Loop

End Sub

 

[jlight]

Thanks that works perfectly.