Solved: TRANSPOSE DATA IN COLUMNS INTO ROWS USING A PRIMARY KEY

[robertstewar]

Hi there,
Nice forum: )
i have data in a column B:B that has a primary key in A:A.
This data might well have duplicates, and i want to be able to transpose this so that the data can appear on one row with multiple entries to the right for as many columns as necessary.


Kind of like this..

primary keydata
00001 123
00001 456
00001 123
00002 987
00002 357
00002 651
00005 987
00005 654
00005 987

to look like this...


00001 123 456 123
00002 987 357 651
00005 987 654 987


I would use the transpose function but i have 20,000 rows of information to deal with - can anyone recommend a script, or write a script, or have a script that may have been used in the past!?

I have searched the forums, but i could only find transposing, but not using a primary key

Help would be appreciated,
Thanks again,
Rob

[stanleydgrom]

robertstewar,

With your original data in Sheet1, beginning in cell A1, the macro will combine the data into Sheet2.


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Adding the Macro

1. Copy the below macro, by highlighting the macro code and pressing the keys CTRL+C
2. Open your workbook
3. Press the keys ALT+F11 to open the Visual Basic Editor
4. Press the keys ALT+I to activate the Insert menu
5. Press M to insert a Standard Module
6. Paste the code by pressing the keys CTRL+V
7. Press the keys ALT+Q to exit the Editor, and return to Excel.



Option Explicit
Sub Test()
Dim a, i As Long, y, w()
a = ThisWorkbook.Sheets("Sheet1").Range("a1").CurrentRegion.Resize(, 2).Value
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
.Add a(i, 1), Array(a(i, 1), a(i, 2))
Else
w = .Item(a(i, 1))
ReDim Preserve w(UBound(w) + 1)
w(UBound(w)) = a(i, 2)
.Item(a(i, 1)) = w
End If
Next
y = .items
End With
With ThisWorkbook.Sheets("Sheet2").Range("a1")
.CurrentRegion.Clear
For i = 0 To UBound(y)
.Offset(i).Resize(, UBound(y(i)) + 1).Value = y(i)
Next
End With
End Sub



Then run the "Test" macro.


Have a great day,
Stan

[robertstewar]

top stuff Stan... you're a legend, that works like a dream :)

Now, to add another variable to this - can a script be added to this to remove any duplicates in column B:B?

As a thought - is it worthwhile having this as a separate macro?

Have a great day too matey :)

[mdmackillop]

Hi Stan,
Nice solution.
FYI, if you use the green VBA button when you post code, it will format it as shown. "Code" tags won't do that here.
Regards
MD

[stanleydgrom]

MD,

Thanks. Will remember that in the future.

Have a great day,
Stan

[stanleydgrom]

robertstewar,

This new code will also delete the duplicate "keydata" on Sheet2.



Option Explicit
Sub Test()
Dim a, i As Long, y, w()
Dim LR As Long, LR2 As Long, LUC As Long, LC As Long, b As Long, rng As Range, rng2 As Range
Application.ScreenUpdating = False
a = ThisWorkbook.Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 2).Value
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
.Add a(i, 1), Array(a(i, 1), a(i, 2))
Else
w = .Item(a(i, 1))
ReDim Preserve w(UBound(w) + 1)
w(UBound(w)) = a(i, 2)
.Item(a(i, 1)) = w
End If
Next
y = .items
End With
With ThisWorkbook.Sheets("Sheet2")
With .Range("A1")
.CurrentRegion.Clear
For i = 0 To UBound(y)
.Offset(i).Resize(, UBound(y(i)) + 1).Value = y(i)
Next
End With
LR = .Cells(Rows.Count, 2).End(xlUp).Row
LUC = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
For a = 2 To LR Step 1
.Cells(1, LUC + 2) = "Test"
LC = .Cells(a, Columns.Count).End(xlToLeft).Column
Set rng = .Range(.Cells(a, 2), .Cells(a, LC))
rng.Copy
With .Cells(2, LUC + 2)
.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End With
LR2 = .Cells(Rows.Count, LUC + 2).End(xlUp).Row
.Range(.Cells(1, LUC + 2), .Cells(LR2, LUC + 2)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range(.Cells(1, LUC + 3), .Cells(1, LUC + 3)), Unique:=True
rng.ClearContents
Set rng2 = .Range(.Cells(2, LUC + 3), .Cells(LR2, LUC + 3))
rng2.Copy
With rng
.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End With
.Range(.Cells(1, LUC + 2), .Cells(LR2, LUC + 3)).ClearContents
Next a
Application.CutCopyMode = False
End With
ThisWorkbook.Sheets("Sheet2").Select
Range("A1").Select
Application.ScreenUpdating = True
End Sub

[robertstewar]

Stan - thanks for this, it works a treat! - youve been a great help :)

[Aussiebear]

HI Stan,

Would you give some consideration as to entering this in the KB?

[Krishna Kumar]

Hi,

Sub kTest()
Dim k, q(), i As Long, n As Long, s As String
Dim dic1 As Object, dic2 As Object, eCol As Long

k = Sheets("Sheet1").Range("a1").CurrentRegion.Offset(1).Resize(, 2)
ReDim q(1 To UBound(k, 1), 1 To Columns.Count)
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
dic1.comparemode = 1: dic2.comparemode = 1
For i = 1 To UBound(k, 1)
s = k(i, 1) & "|" & k(i, 2)
If Not dic1.exists(k(i, 1)) Then
n = n + 1
q(n, 1) = k(i, 1): q(n, 2) = k(i, 2)
dic1.Add k(i, 1), Array(n, 2)
dic2.Add s, Nothing
Else
If Not dic2.exists(s) Then
r = dic1.Item(k(i, 1)): r(1) = r(1) + 1
q(r(0), r(1)) = k(i, 2)
dic2.Add s, Nothing
eCol = Application.Max(eCol, r(1))
dic1.Item(k(i, 1)) = r
End If
End If
Next
With Sheets("Sheet1").Range("d1")
.Resize(n, eCol).Value = q
End With
End Sub

HTH