Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
?
Solved

Revise Excel macro to include missing information

Posted on 2016-10-17
4
Medium Priority
?
79 Views
Last Modified: 2016-10-17
The attached file contains two worksheets.
A script parses the information in worksheet "Original" into the information in worksheet "Results"

There are 2 requests:
1. Worksheet "Original" contains price information in column F and in column B. Example in cells B70 to B87 (and other cells below) shows price information that is incorrectly parsed to Column F in worksheets "Results".
The requirement is for the script to be amended so that all price information in column F and B, of the Original worksheet, is parsed to Column F in Results worksheet.

2. Worksheet "Original" contains the word with colon "Category:"  as part of the information in column E.
The requirement is to have this word with colon "Category:" deleted from the worksheet "Results".

Thanks,
Greg
2016-10-04-Sales.xlsx
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
  • 2
  • 2
4 Comments
 
LVL 53

Expert Comment

by:Rgonzo1971
ID: 41846380
Hi,

pls try
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, strSize 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"
    Range("J1").Value = "Size"
    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)
                varPrice = cl.Offset(0, 1).Value
                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) = Replace(strType, "Category:", "")
                    .Cells(intRow, 7) = strMonth
                    .Cells(intRow, 8) = intYear
                    .Cells(intRow, 9) = varPrice
                    .Cells(intRow, 10) = strSize
                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
                strSize = cl.Offset(0, 6).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, 10), Header:=xlYes
End Sub

Open in new window

Regards
0
 

Author Comment

by:gregfthompson
ID: 41846394
Thanks. Great job.

There'a another small request. I overlooked that "Land Size:" (Original column G) is also not deleted from the Results (column J).

Can you make this amendment as well?

Thanks,

Greg
0
 
LVL 53

Accepted Solution

by:
Rgonzo1971 earned 2000 total points
ID: 41846423
then try
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, strSize 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"
    Range("J1").Value = "Size"
    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)
                varPrice = cl.Offset(0, 1).Value
                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) = Replace(strType, "Category:", "")
                    .Cells(intRow, 7) = strMonth
                    .Cells(intRow, 8) = intYear
                    .Cells(intRow, 9) = varPrice
                    .Cells(intRow, 10) = Replace(strSize, "Land Size:", "")
                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
                strSize = cl.Offset(0, 6).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, 10), Header:=xlYes
End Sub

Open in new window

0
 

Author Closing Comment

by:gregfthompson
ID: 41846437
Magnificent. Thanks heaps.
0

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

Question has a verified solution.

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

When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
Do you use a spreadsheet like Microsoft's Excel?  Have you ever wanted to link out to a non excel file on your computer or network drive?  This is the way I found to do it!
Graphs within dashboards are meant to be dynamic, representing data from a period of time that will change each time the dashboard is updated with new data. Rather than update each graph to point to a different set within a static set of data, t…
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

636 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