Transpose Columns with Duplicate Values into Single Row

[dabigmonky]

Hello, how can I transpose columns with duplicate values and remove duplicates while placing the remaining values into rows?

Here is what my data looks like:

Here is what I'd like it to look like:

 

[Weazel]

maybe something like...

Excel 2012

	A	B	C	D	E	F
1	Kit	Component
2	ABC	S001
3	ABC	S002
4	ABC	S003
5	DEF	S006
6	DEF	S007
7	DEF	S008
8	DEF	S009
9
10
11	ABC	S001	S002	S003
12	DEF	S006	S007	S008	S009

<tbody>
</tbody>

Sheet1​

Worksheet Formulas Cell Formula B11 =IFERROR(INDEX($B$2:$B$8,AGGREGATE(15,6,(ROW($A$2:$A$8)-ROW($A$2)+1)/($A$2:$A$8=$A11),COLUMNS($B11:B11))),"") <tbody> </tbody>

<tbody>
</tbody>

 

[WarPigl3t]

Sub myMacro()
    i = 2
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    Do Until i > lastRow
        ii = i
        Do Until ii > lastRow
            If ii = i Then
                c = 3
            ElseIf Cells(ii, 1).Value = Range("A" & i).Value
                Cells(i, c).Value = Range("B" & ii).Value
                c = c + 1
                Rows(ii).Delete
                ii = ii - 1
                lastRow = Range("A" & Rows.Count).End(xlUp).Row
            End If
            ii = ii + 1
        Loop
        i = i + 1
    Loop
End Sub

 

[dabigmonky]

Sub myMacro()
    i = 2
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    Do Until i > lastRow
        ii = i
        Do Until ii > lastRow
            If ii = i Then
                c = 3
            ElseIf Cells(ii, 1).Value = Range("A" & i).Value
                Cells(i, c).Value = Range("B" & ii).Value
                c = c + 1
                Rows(ii).Delete
                ii = ii - 1
                lastRow = Range("A" & Rows.Count).End(xlUp).Row
            End If
            ii = ii + 1
        Loop
        i = i + 1
    Loop
End Sub

I received a "Compile Error: Syntax Error"
ElseIf Cells(ii, 1).Value = Range("A" & i).Value

 

[WarPigl3t]

add "Then" at the end of that line.

 

[hiker95]

dabigmonky,

With you raw data already sorted/grouped by the Kit's in column A.

Sample raw data:

Excel 2007
	A	B	C	D	E
1	Kit	Component
2	ABC	S001
3	ABC	S002
4	ABC	S003
5	DEF	S006
6	DEF	S007
7	DEF	S008
8	DEF	S009
9
Sheet1

After the macro, and, function:

Excel 2007
	A	B	C	D	E
1	Kit	Component	Component	Component	Component
2	ABC	S001	S002	S003
3	DEF	S006	S007	S008	S009
4
5
6
7
8
9
Sheet1

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).

1. Copy the below code, and, function
2. Open your NEW 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. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub ReorgData()
' hiker95, 11/19/2014, ME819244
Dim o As Variant, j As Long, c As Long, mc As Long
Dim Rng As Range, nlr As Long
Dim r As Long, lr As Long, rr As Long, sr As Long, er As Long, n As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = Range("A2:A" & lr)
nlr = CountUnique(Rng)
ReDim o(1 To nlr, 1 To lr)
For r = 2 To lr
  n = Application.CountIf(Columns(1), Cells(r, 1).Value)
  If n > mc Then mc = n
  If n = 1 Then
    j = j + 1
    o(j, 1) = Cells(r, 1).Value: o(j, 2) = Cells(r, 2).Value
  ElseIf n > 1 Then
    j = j + 1
    o(j, 1) = Cells(r, 1).Value: o(j, 2) = Cells(r, 2).Value
    c = 3
    sr = r + 1: er = sr + n - 2
    For rr = sr To er
      o(j, c) = Cells(rr, 2).Value
      c = c + 1
    Next rr
  End If
  r = r + n - 1
Next r
Range("A2:B" & lr).ClearContents
Cells(1, 3).Resize(, mc - 1).Value = Cells(1, 2).Value
Range("A2").Resize(UBound(o, 1), UBound(o, 2)).Value = o
Columns(1).Resize(, 2 + mc).AutoFit
Application.ScreenUpdating = True
End Sub
Function CountUnique(ByVal Rng As Range) As Long
' Juan Pablo González, MrExcel MVP, 05/09/2003
' http://www.mrexcel.com/forum/excel-questions/48385-need-count-unique-items-column-visual-basic-applications.html
Dim St As String
Set Rng = Intersect(Rng, Rng.Parent.UsedRange)
St = "'" & Rng.Parent.Name & "'!" & Rng.Address(False, False)
CountUnique = Evaluate("SUM(IF(LEN(" & St & "),1/COUNTIF(" & St & "," & St & ")))")
End Function

Before you use the macro, and, function, with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgData macro.

 

[UDIPTI]

dabigmonky,

With you raw data already sorted/grouped by the Kit's in column A.

Sample raw data:

Excel 2007

	A	B	C	D	E
1	Kit	Component
2	ABC	S001
3	ABC	S002
4	ABC	S003
5	DEF	S006
6	DEF	S007
7	DEF	S008
8	DEF	S009
9

<colgroup><col style="width: 25pxpx"><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Sheet1​

After the macro, and, function:

Excel 2007

	A	B	C	D	E
1	Kit	Component	Component	Component	Component
2	ABC	S001	S002	S003
3	DEF	S006	S007	S008	S009
4
5
6
7
8
9

<colgroup><col style="width: 25pxpx"><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Sheet1​

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).

1. Copy the below code, and, function
2. Open your NEW 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. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub ReorgData()
' hiker95, 11/19/2014, ME819244
Dim o As Variant, j As Long, c As Long, mc As Long
Dim Rng As Range, nlr As Long
Dim r As Long, lr As Long, rr As Long, sr As Long, er As Long, n As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = Range("A2:A" & lr)
nlr = CountUnique(Rng)
ReDim o(1 To nlr, 1 To lr)
For r = 2 To lr
  n = Application.CountIf(Columns(1), Cells(r, 1).Value)
  If n > mc Then mc = n
  If n = 1 Then
    j = j + 1
    o(j, 1) = Cells(r, 1).Value: o(j, 2) = Cells(r, 2).Value
  ElseIf n > 1 Then
    j = j + 1
    o(j, 1) = Cells(r, 1).Value: o(j, 2) = Cells(r, 2).Value
    c = 3
    sr = r + 1: er = sr + n - 2
    For rr = sr To er
      o(j, c) = Cells(rr, 2).Value
      c = c + 1
    Next rr
  End If
  r = r + n - 1
Next r
Range("A2:B" & lr).ClearContents
Cells(1, 3).Resize(, mc - 1).Value = Cells(1, 2).Value
Range("A2").Resize(UBound(o, 1), UBound(o, 2)).Value = o
Columns(1).Resize(, 2 + mc).AutoFit
Application.ScreenUpdating = True
End Sub
Function CountUnique(ByVal Rng As Range) As Long
' Juan Pablo González, MrExcel MVP, 05/09/2003
' http://www.mrexcel.com/forum/excel-questions/48385-need-count-unique-items-column-visual-basic-applications.html
Dim St As String
Set Rng = Intersect(Rng, Rng.Parent.UsedRange)
St = "'" & Rng.Parent.Name & "'!" & Rng.Address(False, False)
CountUnique = Evaluate("SUM(IF(LEN(" & St & "),1/COUNTIF(" & St & "," & St & ")))")
End Function

Before you use the macro, and, function, with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgData macro.

Is there any limitations to this script. I have used it a few times before with no issues. Here is an example of the data I am trying to use. There is 24,000 Records with no more than 16 unique items.

ITEM NUMBER 1 L012101300100 1 L012101300200 1 L012101400100 1 L012101400200 1 L012101500100 1 L012101500200 1 L012101600100 1 L012101600200 2 L012102300100 2 L012102300200 2 L012102400100 2 L012102400200 2 L012102500100 2 L012102500200 2 L012102600100 2 L012102600200 <colgroup><col><col></colgroup><tbody> </tbody>

<colgroup><col><col></colgroup><tbody>
</tbody>

I get an error that says run-time error '1004': Application-defined or object-defined error. When I debug it highlights this line: Range("A2").Resize(UBound(o, 1), UBound(o, 2)).Value = o

Any idea why this is happening. I appreciate the help

 

[hiker95]

UDIPTI,

1. What version of Excel and Windows are you using?

2. Are you using a PC or a Mac?

3. Are your ITEM numbers in column A, beginning in cell A2, grouped and sorted together?

4. Are there any blank cells/rows in your raw data?

 

[UDIPTI]

UDIPTI,

1. What version of Excel and Windows are you using?

• Excel 2013 & Windows 7

2. Are you using a PC or a Mac?

• PC

3. Are your ITEM numbers in column A, beginning in cell A2, grouped and sorted together?

• Yes the item numbers begin in A2 and are grouped and sorted together.

4. Are there any blank cells/rows in your raw data?

• No there are no blank cells/rows in the raw data.

I uploaded the list to a google doc if you would like to take a look.

https://docs.google.com/spreadsheets/d/1Y0zBFamWjGaFUzHQWbB4Kqp79N1HFEGVWIpXXGYyLC8/edit?usp=sharing

 

[hiker95]

i uploaded the list to a google doc if you would like to take a look.

https://docs.google.com/spreadsheets...it?usp=sharing

UDIPTI,

That does not work for me. It is asking me to Sign In?


You can post your workbook/worksheets to the following free site (sensitive data changed), mark the workbook for sharing, and, provide us with a link to your workbook:

https://dropbox.com