Revise list in Excel - parse, repeat and delete rows

The macro in the attached file has decided to not work.
EE-problem-revision-3182-rent-April-2015
gregfthompsonAsked:
Who is Participating?
 
Roy CoxGroup Finance ManagerCommented:
I think this fixes it

Option Explicit

Sub Transpose_Listings()
    Dim rng As Range
    Dim cl As Range
    Dim strAddress As String, strSub As String, strType As String, strMonth As String
    Dim intBed As Integer, intBath As Integer, intCar As Integer, intYear As Integer
    Dim v As Variant, varPrice As Variant
    Dim intRow As Long

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    Set rng = Worksheets(1).Range("A2:A" & Worksheets(1).Cells.SpecialCells(xlLastCell).Row)

    On Error Resume Next
    Sheets("Results").Delete
    On Error GoTo 0
    Sheets.Add After:=Sheets(1)
    ActiveSheet.Name = "Results"
    Range("A1").Value = "Address"
    Range("B1").Value = "Suburb"
    Range("C1").Value = "Bed"
    Range("D1").Value = "Bath"
    Range("E1").Value = "Car"
    Range("F1").Value = "Type"
    Range("G1").Value = "Month"
    Range("H1").Value = "Year"
    Range("I1").Value = "Price"
    intRow = 2

    For Each cl In rng
        Select Case LCase(cl.Value)
        Case "address"    'start of data block
            'skip
        Case "date and price list"
            'skip
        Case "date"
            'skip
        Case ""
            'skip
        Case Else
            If IsDate(cl.Value) Then            'pricing data - write to Results sheet
                v = CDate(cl.Value)
                strMonth = Format(v, "mmmm")
                intYear = Year(v)
                If InStr(1, cl.Offset(0, 1).Value, " ") = 0 Then
                    varPrice = cl.Offset(0, 1).Value
                Else
                    varPrice = Val(Mid(cl.Offset(0, 1).Value, 2, InStr(1, cl.Offset(0, 1).Value, " ") - 1))
                End If
                With Sheets("Results")
                    .Cells(intRow, 1) = strAddress
                    .Cells(intRow, 2) = strSub
                    .Cells(intRow, 3) = intBed
                    .Cells(intRow, 4) = intBath
                    .Cells(intRow, 5) = intCar
                    .Cells(intRow, 6) = strType
                    .Cells(intRow, 7) = strMonth
                    .Cells(intRow, 8) = intYear
                    .Cells(intRow, 9) = varPrice
                End With
                intRow = intRow + 1
            Else
                intBed = 0
                intBath = 0
                intCar = 0
                strAddress = Left(cl.Value, InStr(1, cl.Value, ",") - 1)
                strSub = Mid(cl.Value, InStr(1, cl.Value, ",") + 2)
                If cl.Offset(0, 1).Value <> "" Then intBed = Right(cl.Offset(, 1).Value, (Len(cl.Offset(, 1).Value) - InStr(cl.Offset(, 1).Value, ":")))
                If cl.Offset(0, 2).Value <> "" Then intBath = Right(cl.Offset(, 2).Value, (Len(cl.Offset(, 2).Value) - InStr(cl.Offset(, 2).Value, ":")))
                If cl.Offset(0, 3).Value <> "" Then intCar = Right(cl.Offset(, 3).Value, (Len(cl.Offset(, 3).Value) - InStr(cl.Offset(, 3).Value, ":")))
                strType = cl.Offset(0, 4).Value
            End If
        End Select
    Next cl

    With Sheets("Results")
        .Range("A:G").EntireColumn.AutoFit
        .Range("I2:I" & intRow).NumberFormat = "$#,##0"
    End With

    RemoveDuplicates

    Application.DisplayAlerts = True
    MsgBox "Done."
End Sub

Private Sub RemoveDuplicates()
    Application.CutCopyMode = False
    Worksheets("Results").UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9), Header:=xlYes
End Sub

Open in new window

0
 
Roy CoxGroup Finance ManagerCommented:
Have you changed the format of the cells used to create the list?
0
 
gregfthompsonAuthor Commented:
Thanks - perfect!
0
 
Roy CoxGroup Finance ManagerCommented:
Glad to help
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.