HOW CAN I COPY COLUMN TO ROWS

Closed
buds - Sep 20, 2009 at 08:06 AM
venkat1926 Posts 1864 Registration date Sunday June 14, 2009 Status Contributor Last seen August 7, 2021 - Sep 20, 2009 at 10:45 PM
Hello,

Can anybody help me on this? please provide me a macro(VB) to solve this problem,

I have 1st column with heading "geocode" and 2nd column "house no". Geocode column has several records but there are cells that have the same value. i want to copy the second column "house no" into rows for as long as the first column "geocode" has the same value of records. If the range of value in cells in the first column changes, it will copy again the 2nd column "houseno" but the 1st record will fall on the 1st column of the previous one converted into rows;

see illustration below

geocode house no (the result would be, see below this text)
1 2 geocode houseno 1 houseno 2 houseno 3
1 3 1 2 3 4
1 4 2 lot 1 lot 2 lot 3
2 lot 1
2 lot 2
2 lot 3

1 reply

venkat1926 Posts 1864 Registration date Sunday June 14, 2009 Status Contributor Last seen August 7, 2021 810
Sep 20, 2009 at 10:45 PM
It is not clear what you want
suppose you are having data like this from A1 to B6 in sheet 1
geocode house no.
2 lot 1
2 lot 2
2 lot 3
3 lot 4
3 lot 5
you want in sheet 2 something like this
geocode
2 lot 1 lot 2 lot 3
3 lot 4 lot 5
If this assumption is correct then use this macro (along with the function) . the result will be in sheet 2.
The findall function is taken from Pearson.

Sub test()
Dim rng As Range, rng1 As Range, x, c1 As Range, m As Integer
Dim foundrange As Range, resultrange As Range
m = 0
Worksheets("sheet2").Cells.Clear
With Worksheets("sheet1")
Set rng = Range(.Range("A1"), .Range("A1").End(xlDown))
rng.AdvancedFilter action:=xlFilterCopy, copytorange:=Worksheets("sheet2").Range("a1"), unique:=True
Do
x = Worksheets("sheet2").Range("a2").Offset(m, 0)
If x = "" Then Exit Do
 Set foundrange = findall(rng, x)
 If foundrange Is Nothing Then Exit Do
foundrange.Offset(0, 1).Copy
Worksheets("sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).PasteSpecial , Transpose:=True

m = m + 1
Loop
End With


End Sub
Function findall(source As Range, findwhat) As Range
Dim foundcell As Range
Dim firstfound As Range
Dim lastcell As Range
Dim resultrange As Range
With source
Set lastcell = .Cells(.Cells.Count)
End With
On Error Resume Next
On Error GoTo 0
Set foundcell = source.Cells.Find(what:=findwhat, LookAt:=xlWhole)
If Not foundcell Is Nothing Then
Set firstfound = foundcell
Set resultrange = foundcell
End If
Do
Set foundcell = source.Cells.FindNext(after:=foundcell)
If foundcell Is Nothing Then Exit Do
If foundcell.Address = firstfound.Address Then Exit Do
Set resultrange = Application.Union(resultrange, foundcell)
Loop
Set findall = resultrange
End Function

0