HOW CAN I COPY COLUMN TO ROWS

Closed
Report
-
Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
-
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

Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
803
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