Loop Required to Transpose Data from Columns to Rows

mbf1

New Member
Joined
Sep 17, 2006
Messages
6
Hi, I have been struggling to transpose 3 columns of data into rows for the last week. The data relates to a huge number of part numbers - some part numbers have only 5 different field names while others have up to 39 different fields names. Column 1 contains the part number (repeated until next part), colum 2 contains the field name, column 3 contains the field value.

The end result i need is row 1 containing the 39 different field names and Column 1 containing all the part numbers, with the field values inserted accordingly, maybe using a vlookup.

Would very much appreciate your feedback
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
What i understand is u want a table,
Code:
	    Field-1    Field-2   Field-3
Part-1	(cellA1)	 (B1)	(C1)
Part-2	(A2)	     (B2)	(C2)
Part-3	(A3)	     (B3)	(C3)
And what u have is

Code:
ColA         B        C
Part-1	Field-1	Value
Part-1	Field-2	Value
Part-2	Field-1	Value
Part-2	Field-2	Value
Part-2	Field-3	Value
The idea is replace part number and Fields with number (Part-1 with 1, Part-2 with 2 and Fields-1 with 1, Fields-2 with 2 ...so on
so ur data will look like


Code:
A	B	C
1	1	Value
1	2	Value
2	1	Value
2	2	Value
2	3	Value

now if u can see - A is Row index and B is Column Index and C gives the value u want to put.
Code a simple macro to put values from column C in cell(a,b)

Code:
For i = 1 to limit                              <- limit = total # of values in column C
     a = range("A" & i).value             <- get row index
     b = range("B" & i).value             <- get column index
     c = range("C" & i).value             <- get value
     cell(a,b).value = c                     <- put value in cell(a,b)]
Next
 
Upvote 0
Hi,

Code:
Sub test()
Dim Part        As Range
Dim FieldList   As Range
Dim FieldNames  As Range
Dim FieldName   As Range

Application.ScreenUpdating = False
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("E1" _
        ), Unique:=True
    Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("F1" _
        ), Unique:=True
    Range("F2", [f65536].End(xlUp)).Copy
    Range("F1").PasteSpecial , , , True
    Range("F2", [f65536].End(xlUp)).ClearContents
Set FieldList = Range("F1", [iv1].End(xlToLeft))
    For Each Part In Range("E2", [e65536].End(xlUp))
        With Range("A1:C" & [a65536].End(xlUp).Row)
            .AutoFilter field:=1, Criteria1:=Part
            Set FieldNames = .Offset(1, 1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
            For Each FieldName In FieldNames
                x = Application.WorksheetFunction.Match(FieldName, FieldList, 0)
                Part.Offset(, x) = FieldName.Offset(, 1).Value
            Next FieldName
            .AutoFilter
        End With
    Next Part
Application.ScreenUpdating = True
End Sub

HTH
 
Upvote 0
Hi,

I see that Kris has beaten me to it, but here's my solution for what it's worth :¬/

Code:
Sub TransposePartNums()
Dim R As Range
Dim dCurValue As Double
Dim sCurPart As String, sCurName As String
Dim vRowPartNum As Variant, vColName As Variant
Dim wsFr As Worksheet, wsTo As Worksheet

'-- Set 'From' & 'To' sheets --
Set wsFr = Sheets("Sheet1")
Set wsTo = Sheets("Sheet2")

'-- Clear 'To' sheet data --
wsTo.UsedRange.ClearContents

For Each R In wsFr.Range("A2:A" & wsFr.Cells(Rows.Count, "A").End(xlUp).Row)
    sCurPart = R.Text
    sCurName = R.Offset(0, 1).Text
    dCurValue = Val(R.Offset(0, 2).Value)
    vRowPartNum = "*"
    On Error Resume Next
    vRowPartNum = WorksheetFunction.Match(sCurPart, wsTo.Columns("A"), 0)
    On Error GoTo 0
    If IsNumeric(vRowPartNum) = False Then
        vRowPartNum = wsTo.Cells(Rows.Count, "A").End(xlUp).Row + 1
        wsTo.Cells(vRowPartNum, "A").Value = sCurPart
    End If
    On Error Resume Next
    vColName = "*"
    vColName = WorksheetFunction.Match(sCurName, wsTo.Rows(1), 0)
    On Error GoTo 0
    If IsNumeric(vColName) = False Then
        vColName = wsTo.Cells(1, Columns.Count).End(xlToLeft).Column + 1
        wsTo.Cells(1, vColName).Value = sCurName
    End If
    wsTo.Cells(vRowPartNum, vColName).Value = dCurValue
Next R

End Sub

This copies & transposes the data from Sheet1 to Sheet2
 
Upvote 0
... so if sheet1 looks like:
Book1.xls
ABCD
1Part Numfield NameValue
2AAA0NAME 178
3AAA0NAME 337
4AAA0NAME 492
5AAA0NAME 780
6AAA1NAME 027
7AAA1NAME 482
8AAA1NAME 421
9AAA1NAME 626
10AAA1NAME 828
11AAA2NAME 137
12AAA2NAME 350
13AAA2NAME 422
14AAA2NAME 535
15AAA2NAME 527
16AAA2NAME 786
17AAA2NAME 977
18AAA3NAME 067
19AAA3NAME 129
20AAA3NAME 238
21AAA3NAME 321
22AAA3NAME 683
23AAA3NAME 771
24AAA3NAME 980
25AAA4NAME 146
Sheet1


Sheet2 will look like:
Book1.xls
ABCDEFGHIJK
1NAME 1NAME 3NAME 4NAME 7NAME 0NAME 6NAME 8NAME 5NAME 9NAME 2
2AAA078379280
3AAA121272628
4AAA2375022862777
5AAA329217167838038
6AAA446269514732
7AAA542670
8AAA678125298978726
9AAA7471833171899350
10AAA834433453737
11AAA91450890585836
Sheet2
 
Upvote 0
Thanks it worked !

Thanks to everyone who contributed my post - I am overwhelmed by your responses ! Firstly I tried Krishnakumar's code which errored out part way thru. I then tried al_b_cnu's code and it worked beautifully !

I am now studying all the code submitted and try to work thru how you've put these bit of code together. BTW I purchased the Mr Excel book of VBA and Macros for Excel to try to solve this problem, but now feel the problem's a bit too advanced for my first forays into VBA.

Thanks again everyone !
 
Upvote 0

Forum statistics

Threads
1,213,550
Messages
6,114,265
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top