Tidying a list of records into a database

jlight

New Member
Joined
Jun 25, 2003
Messages
29
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
 

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
Does this code work okay for you?
Code:
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
 
Upvote 0

Forum statistics

Threads
1,223,492
Messages
6,172,600
Members
452,466
Latest member
Lynlindsay

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