gregfthompson
asked on
Excel - amend script to include column G
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
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
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.
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.
ASKER
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
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
Hi,
pls try
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
Regards
ASKER
Thanks.
It would not run. Window said "Invalid outside procedure"
It would not run. Window said "Invalid outside procedure"
Are the size results in the correct rows?
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
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
ASKER
Thanks. That works perfectly.
Could you please post the script so we can make amendments as you describe?