PDA

View Full Version : Solved: consolidating columns



vzachin
06-23-2006, 05:37 AM
hi,

i want to consolidate data into 2 columns. currently i have data in 5 columns where column A contains city names and columns B,C,D,E contains corrresponding street names. i want to have the cities in 1 column and the streets in another column.

column A can contain 1 or more rows, maximum 20000.

i have no clue as to how to begin writing a macro for this. can someone please help me?

thanks
vzac

ALe
06-23-2006, 06:34 AM
Have a look

mvidas
06-23-2006, 07:06 AM
vzac,

Though a bit longer than ALe's method, this will work much much quicker on your bigger sheets (unnoticeable on the smaller ones). Plus if you plan on doing anything with the data afterwards, you can always adapt this to just re-use the consolidated data array. If you have any questions, just ask!Sub vzachin()
Dim SheetData(), R As Long, C As Long, ConsolData() As String, Cnt As Long
Dim FirstRow As Long, UsedRG As Range

FirstRow = 2 'skip header row(s)

With ActiveSheet 'sheet to consolidate from, create a Range object of data
Set UsedRG = Intersect(.UsedRange, .Rows(FirstRow & ":" & .Rows.Count), .Columns("A:E"))
End With
If UsedRG Is Nothing Then Exit Sub 'if there is no data, quit
SheetData = UsedRG.Value 'put data into array variable
ReDim ConsolData(1, 0) 'initialize array for consolidated data
For R = 1 To UBound(SheetData, 1) 'loop through data rows
For C = 2 To UBound(SheetData, 2) 'loop through data columns
If Len(SheetData(R, C)) > 0 Then 'if there is a street listed in data
ReDim Preserve ConsolData(1, Cnt) 'redimension consolidated data array
ConsolData(0, Cnt) = SheetData(R, 1) 'put city name in consolidated array
ConsolData(1, Cnt) = SheetData(R, C) 'put street name in consolidated array
Cnt = Cnt + 1 'increase counter variable
End If
Next 'C
Next 'R

Application.ScreenUpdating = False
Sheets.Add 'put ConsolData into new sheet, you could delete old data instead
Range("A1:B1").Value = Array("CITY", "STREET") 're-enter header data
vStrTranspose ConsolData 'transpose consolidated array for easier transfer
Range("A2").Resize(Cnt, 2).Value = ConsolData 'transfer data to new sheet
Columns.AutoFit 'resize columns to fit all data
Application.ScreenUpdating = True
End Sub
Function vStrTranspose(ByRef vArray() As String) As Boolean
Dim tempArr() As String, R As Long, C As Long
Dim iLB1 As Long, iUB1 As Long, iLB2 As Long, iUB2 As Long
iLB1 = LBound(vArray, 1)
iUB1 = UBound(vArray, 1)
iLB2 = LBound(vArray, 2)
iUB2 = UBound(vArray, 2)
ReDim tempArr(iLB2 To iUB2, iLB1 To iUB1)
For R = iLB1 To iUB1
For C = iLB2 To iUB2
tempArr(C, R) = vArray(R, C)
Next
Next
ReDim vArray(iLB2 To iUB2, iLB1 To iUB1)
For R = iLB1 To iUB1
For C = iLB2 To iUB2
vArray(C, R) = tempArr(C, R)
Next
Next
End FunctionMatt

vzachin
06-23-2006, 07:35 AM
thanks a lot ALe & Matt. i don't quite understand either coding but it works!

mdmackillop
06-24-2006, 03:16 AM
Hi Matt,
How about

Sheets.Add 'put ConsolData into new sheet, you could delete old data instead
Range("A1:B1").Value = Array("CITY", "STREET") 're-enter header data
Range("A2").Resize(Cnt, 2).Value = _
Application.WorksheetFunction.Transpose(ConsolData)

mvidas
06-24-2006, 04:57 AM
The application.transpose function only handles arrays of 5461 items (at least in my xl2k, I forget about the other versions), but when I made a 20,000 row test book which ended up with an array with 50,000 items in it, it would have errored out. I didn't even bother with it, I almost never use that unless I'm sure of the array size

mdmackillop
06-24-2006, 05:05 AM
Didn't know of these limits Matt. Testing it in 2003 with Data copied down to 20k rows, it is transposing the result into 60k rows, so I guess they've increased.

mvidas
06-24-2006, 05:15 AM
I don't remember where I tested that limit to find it, let me write something real quick to test it again (I have excel 2000 at home but with service packs, unlike at work) see if the limit is still there.
Yep, errored at 5462 again for me:Sub ldfkjd()
Dim TheArray(), i As Long
ReDim TheArray(1 To 5000)
For i = 1 To 5000
TheArray(i) = i
Next
Application.ScreenUpdating = False
On Error GoTo StopIt
For i = 5001 To 65536
ReDim Preserve TheArray(1 To i)
TheArray(i) = i
Range("A1").Resize(i, 1).value = Application.Transpose(TheArray)
Next
StopIt:
Application.ScreenUpdating = True
If i < 65537 Then MsgBox i & " caused an error"
End Sub
'or even
Sub ldfkasdfjd()
Dim TheArray(), i As Long, Array2()
On Error GoTo StopIt
For i = 1 To 65536
ReDim Preserve TheArray(1 To i)
TheArray(i) = i
Array2 = Application.Transpose(TheArray)
Next
StopIt:
If i < 65537 Then MsgBox i & " caused an error"
End Sub Makes the idea of switching versions tempting, but not enough to actually do it (despite the fact that I do have office 2003 :)).