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
Solved

Excel - amend script to include column G

Posted on 2016-08-29
9
52 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
  • 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 18

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
Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
LVL 50

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 18

Expert Comment

by:Roy_Cox
ID: 41774423
Are the size results in the correct rows?
0
 
LVL 50

Accepted Solution

by:
Rgonzo1971 earned 500 total points
ID: 41774428
0
 
LVL 30

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

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

Question has a verified solution.

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

Workbook link problems after copying tabs to a new workbook? David Miller (dlmille) Intro Have you either copied sheets to a new workbook, and after having saved and opened that workbook, you find that there are links back to the original sou…
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.

789 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