Revise list in Excel - parse, repeat and delete rows (macro completed for similar problem)

This problem has been part amended - refer to the work completed in my previous question. here http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28547524.html

The data and price data have been shifted to the left one column from the original data. (This macro is in the attached example)

The original algorithm checked for blank cells in column A as indicators of month/year and price information.  That will not work with this new layout.
Re---Revised-list-for-EE.xlsm
gregfthompsonAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

byundtMechanical EngineerCommented:
You might consider code like shown below. After parsing, it removes the duplicate rows.
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 = Int(Mid(cl.Offset(0, 1), InStr(1, cl.Offset(0, 1).Value, ":") + 2))
                    If cl.Offset(0, 2).Value <> "" Then intBath = Int(Mid(cl.Offset(0, 2), InStr(1, cl.Offset(0, 2).Value, ":") + 2))
                    If cl.Offset(0, 3).Value <> "" Then intCar = Int(Mid(cl.Offset(0, 3), InStr(1, cl.Offset(0, 3).Value, ":") + 2))
                    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

Cheers!

Brad
Revised-list-for-EE-Q28563108.xlsm
0
gregfthompsonAuthor Commented:
Hi Brad,

Thanks. That is fabulous.

Can you now add a function that inserts the correct postcode from the postcode list worksheet?

Is this possible? Or should I make another question?

Thanks again,

Greg
0
byundtMechanical EngineerCommented:
Greg,
I revised the code shown below to add the postcode feature for you. I used arrays to make the code run a little faster and be more compact. I also fixed an issue that occurred when the address has two or more commas (it had been splitting the street address & suburb at the first comma rather than the last one).
Sub Transpose_Listings()
    Dim cl As Range, rgLookup As Range, rng 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 Postcode As Variant, 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)
    Set rgLookup = Worksheets("Postcode & Suburb List").Range("A1").CurrentRegion
    
    On Error Resume Next
    Sheets("Results").Delete
    On Error GoTo 0
    Sheets.Add After:=Sheets(1)
    ActiveSheet.Name = "Results"
    Range("A1:J1").Value = Array("Address", "Suburb", "Postcode", "Bed", "Bath", "Car", "Type", "Month", "Year", "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).Resize(1, 10).Value = _
                            Array(strAddress, strSub, Postcode, intBed, intBath, intCar, strType, strMonth, intYear, varPrice)
                    End With
                    intRow = intRow + 1
                Else
                    intBed = 0
                    intBath = 0
                    intCar = 0
                    strAddress = Left(cl.Value, InStrRev(cl.Value, ",") - 1)
                    strSub = Mid(cl.Value, InStrRev(cl.Value, ",") + 2)
                    Postcode = Application.Match(strSub, rgLookup.Columns(2), 0)
                    Postcode = IIf(IsError(Postcode), "", rgLookup.Cells(CLng(Postcode), 1).Value)
                    If cl.Offset(0, 1).Value <> "" Then intBed = Int(Mid(cl.Offset(0, 1), InStr(1, cl.Offset(0, 1).Value, ":") + 2))
                    If cl.Offset(0, 2).Value <> "" Then intBath = Int(Mid(cl.Offset(0, 2), InStr(1, cl.Offset(0, 2).Value, ":") + 2))
                    If cl.Offset(0, 3).Value <> "" Then intCar = Int(Mid(cl.Offset(0, 3), InStr(1, cl.Offset(0, 3).Value, ":") + 2))
                    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


Brad
Revised-list-for-EE-Q28563108.xlsm
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

gregfthompsonAuthor Commented:
Thanks Brad.

Brilliant work.  Thanks heaps!!!
0
gregfthompsonAuthor Commented:
PS. Column I has the '$' sign.  This should be in column J.
Can you fix?  I've had a look and I have no idea.
0
byundtMechanical EngineerCommented:
Note change to "With Sheets("Results") block at bottom of sub where I set the NumberFormat property of column J. Had been column I.
    With Sheets("Results")
        .Range("A:G").EntireColumn.AutoFit
        .Range("J2:J" & intRow).NumberFormat = "$#,##0"
    End With
    
    RemoveDuplicates
    
    Application.DisplayAlerts = True
    MsgBox "Done."
End Sub

Open in new window

Revised-list-for-EE-Q28563108.xlsm
0
gregfthompsonAuthor Commented:
Got it. Thanks. Much appreciated.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Office

From novice to tech pro — start learning today.

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.