Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

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

Posted on 2014-11-16
7
Medium Priority
?
161 Views
Last Modified: 2014-11-17
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
0
Comment
Question by:gregfthompson
  • 4
  • 3
7 Comments
 
LVL 81

Expert Comment

by:byundt
ID: 40445875
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
 

Author Comment

by:gregfthompson
ID: 40446560
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
 
LVL 81

Accepted Solution

by:
byundt earned 2000 total points
ID: 40446610
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
What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

 

Author Closing Comment

by:gregfthompson
ID: 40446772
Thanks Brad.

Brilliant work.  Thanks heaps!!!
0
 

Author Comment

by:gregfthompson
ID: 40446773
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
 
LVL 81

Expert Comment

by:byundt
ID: 40447320
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
 

Author Comment

by:gregfthompson
ID: 40448303
Got it. Thanks. Much appreciated.
0

Featured Post

[Webinar] Cloud and Mobile-First Strategy

Maybe you’ve fully adopted the cloud since the beginning. Or maybe you started with on-prem resources but are pursuing a “cloud and mobile first” strategy. Getting to that end state has its challenges. Discover how to build out a 100% cloud and mobile IT strategy in this webinar.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Cancel future meetings from user mailboxes in Office 365 using Remove-CalendarEvents
Microsoft has changed the look and feel of Azure AD and Microsoft account sign-in pages so that you will have a more unified look and feel when moving between the two interfaces.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

971 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question