Solved

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

Posted on 2014-11-16
7
158 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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 500 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
NFR key for Veeam Backup for Microsoft Office 365

Veeam is happy to provide a free NFR license (for 1 year, up to 10 users). This license allows for the non‑production use of Veeam Backup for Microsoft Office 365 in your home lab without any feature limitations.

 

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

Office 365 Training for Admins - 7 Day Trial

Learn how to provision tenants, synchronize on-premise Active Directory, implement Single Sign-On, customize Office deployment, and protect your organization with eDiscovery and DLP policies.  Only from Platform Scholar.

Question has a verified solution.

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

Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
How to get Spreadsheet Compare 2016 working with the 64 bit version of Office 2016
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

617 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