Tidying a list of records into a database


New Member
Jun 25, 2003
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
County Durham
Tel: 01910000001

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

London Chiropractic Clinic
3 The Mews
Greater London
Tel: 02087733345

Jack James

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
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

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
    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
        '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

End Sub
Upvote 0

Forum statistics

Latest member

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