View Single Post
 
Old 01-01-2015, 01:04 AM
excelledsoftware excelledsoftware is offline Windows 7 64bit Office 2003
IT Specialist
 
Join Date: Jan 2012
Location: Utah
Posts: 455
excelledsoftware will become famous soon enough
Default

This was actually a lot of fun and I am pretty happy with the result.

Copy and paste this code into a module and then run it. Remember that all VBA code cannot be undone so be sure to save your workbook and have a backup before running.

this code is written with the headers being on row 2. If this needs to change you can change the value of the HeaderRow where it says 'Set the references

Code:
Option Explicit
Sub ParsePropertyData()
  'Takes each value in column A and manipulates the string to contain
  'the proper delimiters.  Cleans the string up of extra spaces and
  'goes through the headers and stores them in an array to search out
  
  Dim CheckString As String, NewString As String, Col As Integer
  Dim CheckRow As Integer, x As Integer, v As Variant, ParseString As String
  Dim Header() As String, LastRow As Integer, LastCol As Integer
  Dim HeaderRow As Integer, StartChar As Integer, EndChar As Integer
  
  'Set the references
  HeaderRow = 2
  LastCol = Range("A" & HeaderRow).End(xlToRight).Column
  LastRow = Range("A" & HeaderRow).End(xlDown).Row
  
  'Set the headers in an array
  ReDim Header(2 To LastCol) As String
  For x = 2 To LastCol
    Header(x) = Cells(HeaderRow, x).Value
  Next x
  
  
  'Format and parse each data row
  For CheckRow = HeaderRow + 1 To LastRow
    CheckString = Range("A" & CheckRow).Value
    'Format the string
    CheckString = Replace(CheckString, ": ", ":")
    For Each v In Header
      If InStr(1, CheckString, v) Then
        CheckString = Replace(CheckString, v, ";" & v)
      End If
    Next v
    'Remove the first semi-colon
    If Left(CheckString, 1) = ";" Then
      CheckString = Mid(CheckString, 2)
    End If
    'Convert to a new string to check
    NewString = WorksheetFunction.Trim(CheckString)
    'Parse the data
    For Col = 2 To LastCol
      If InStr(1, NewString, Header(Col) & ":") Then
        StartChar = InStr(1, NewString, Header(Col) & ":")
        EndChar = InStr(StartChar, NewString, ";") - 1
        If EndChar <> -1 Then
          ParseString = Mid(NewString, StartChar, EndChar - StartChar)
        Else
          ParseString = Mid(NewString, StartChar)
        End If
        'Put the result in the cell
        Cells(CheckRow, Col).Value = Mid(ParseString, InStr(1, ParseString, ":") + 1)
      End If
    Next Col
  Next CheckRow
End Sub

I tested this on your sample and it appears to work 100%
a couple of notes though.
On your attachment you have 2 headers that will need to be changed for this to work and continue to work in the future.

Column B said Rent Price: Needs to be Rent Price (no colon)
Column M said Property should be Property age

Let me know how it works out or if you have any other questions.

Thanks
Reply With Quote