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