How to Create Database from Single Column of Data

[Gary B]

Hi,

I have about one thousand lines of data in a single column. The headings
are repetitive and the data is separated from the heading by a colon (in the
same column). An example is provided below. I would like to create a
database, where the repetitive headings are stripped out and placed
horizontally, and the data filled accordingly, is it possible to automate
this?

OrgName: Corning Incorporated
OrgID: CORNIN
Address: Corning Incorporated
Address: SP-WW-01-1
City: Corning
StateProv: NY
PostalCode: 14831
Country: US

OrgName: University of Michigan Medical Center (MCIT)
OrgID: UMMCM
Address: 4251 Plymouth Rd., Suite 3300
City: Ann Arbor
StateProv: MI
PostalCode: 48105
Country: US

OrgName: Carleton University
OrgID: CARLET-1
Address: Computing and Communications Services
Address: 401 Administration Building
City: Ottawa
StateProv: ON
PostalCode: K1S-5B6
Country: CA

OrgName: Harvard University
OrgID: HARVAR
Address: UIS Network Operations Center
Address: Jay Tumas - Network Operations Manager
Address: 60 Oxford Street
Address: Suite 132
City: Cambridge
StateProv: MA
PostalCode: 02138
Country: US

..
..
..

I would like it to look like the following, so I can use as a database:

Org Name Org ID Address Address City State PostalCode
Company 1 Data
Company 2 Data

Hopefully I do not need to accomplish this by hand every time I get a
Report. Basically I recieve the report in MS Word. I then need to
copy/paste into Excel and from here somehow parse.

Any help or insight provided would be greatly appreciated.

 

[Dave Peterson]

This worked ok for me:

Option Explicit
Sub testme01()

Dim CurWks As Worksheet
Dim NewWks As Worksheet

Dim oRow As Long
Dim oCol As Long

Dim myRng As Range
Dim myCell As Range

Dim myInput As String
Dim myHeader As String
Dim myInfo As String

Dim ColonPos As Long

Dim res As Variant

Dim MaxAddresses As Long
Dim AddressCtr As Long
Dim ErrorFound As Boolean

Set CurWks = ActiveSheet
Set NewWks = Worksheets.Add

With NewWks
MaxAddresses = 5
'notice that there are 5 addresses in the titles.
'the first is Address, the rest are Address#
'make sure you match if you change this
.Range("a1").Resize(1, 6 + MaxAddresses).Value _
= Array("OrgName", "OrgId", _
"Address", "Address2", "Address3", "Address4", _
"Address5", _
"City", "StateProv", "PostalCode", "Country")
.Cells.NumberFormat = "@" 'all text!
End With

With CurWks
Set myRng = .Range("a1", .Cells(.Rows.Count, "A").End(xlUp))
'errors/warnings in column B
.Columns(2).ClearContents
End With

oRow = 1
For Each myCell In myRng.Cells
If Trim(myCell.Value) = "" Then
'do nothing
Else
myInput = Trim(myCell.Value)
ColonPos = InStr(1, myInput, ":", vbTextCompare)
If ColonPos = 0 Then
myCell.Offset(0, 1).Value = "Error: No Colon"
Else
ErrorFound = False
myHeader = Left(myInput, ColonPos - 1)
myInfo = Trim(Mid(myInput, ColonPos + 1))
res = Application.Match(myHeader, NewWks.Rows(1), 0)
If IsError(res) Then
'no match in the headers
myCell.Offset(0, 1).Value = "Error: Wrong Header"
Else
Select Case LCase(myHeader)
Case Is = LCase("orgname")
'new group
oRow = oRow + 1
oCol = res
AddressCtr = -1
Case Is = LCase("Address")
AddressCtr = AddressCtr + 1
If AddressCtr > MaxAddresses Then
ErrorFound = True
myCell.Offset(0, 1).Value _
= "Error: Too many addresses!"
End If
oCol = res + AddressCtr
Case Else
oCol = res
End Select
If ErrorFound Then
'error in addresses, skip it
Else
NewWks.Cells(oRow, oCol).Value = myInfo
End If
End If
End If
End If
Next myCell

NewWks.UsedRange.Columns.AutoFit

End Sub

If you have data in column B of source data, then insert a new column B. This
puts some warnings in those cells.

If you're new to macros, you may want to read David McRitchie's intro at:
http://www.mvps.org/dmcritchie/excel/getstarted.htm

 

[Gary B]

WOW!! Thank you very, very much. Incredible! By the time I got back from
lunch my problem is resolved.

You have saved me tons of work.

Best regards,

Gary