?
Solved

Excel - amend script to include column G

Posted on 2016-08-29
9
Medium Priority
?
62 Views
Last Modified: 2016-08-29
The attached files contain table and a script that re-arranges the data into a different table in a new worksheet called Result.
The script omits column G "size",  when it moves data from the original table.
Many cells under Column G do not have a value, but where there is a value, I would like it to be included in its own column in the Result worksheet.
Example-Excel-file---size-column-re.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
  • 3
  • 2
  • 2
  • +2
9 Comments
 
LVL 18

Expert Comment

by:xtermie
ID: 41774373
hi greg, cant see the script in the macro sheet of the attached example
Could you please post the script so we can make amendments as you describe?
0
 
LVL 21

Expert Comment

by:Roy Cox
ID: 41774395
There is no code within the workbook to edit.

Also, the data is very poorly laid out to work with.

I would suggest that you attach an example with the data and macro in and an additional sheet showing what the end result should be.
0
 

Author Comment

by:gregfthompson
ID: 41774401
Sorry for mucking you about.
My error. More haste, less speed at my end.

The attached file includes a Results example worksheet that includes the required Size column.
If you run the script you will see how the original table is parsed into the more usable Results worksheet.
Example-Excel-file---size-column-re.xlsm
0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 52

Expert Comment

by:Rgonzo1971
ID: 41774415
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)
                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
                    .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: 41774418
Thanks.

It would not run. Window said "Invalid outside procedure"
0
 
LVL 21

Expert Comment

by:Roy Cox
ID: 41774423
Are the size results in the correct rows?
0
 
LVL 52

Accepted Solution

by:
Rgonzo1971 earned 2000 total points
ID: 41774428
0
 
LVL 32

Expert Comment

by:Subodh Tiwari (Neeraj)
ID: 41774437
Try this......

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, varSize As String
    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
        DoEvents
        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
                    .Cells(intRow, 10) = varSize
                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
                varSize = 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), Header:=xlYes
End Sub

Open in new window

0
 

Author Closing Comment

by:gregfthompson
ID: 41774511
Thanks. That works perfectly.
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

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!
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa‚Ķ

752 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