complex transpose VBA

S

Siyanna

Well-known Member
Joined
Nov 7, 2011
Messages
1,146
Hi All

I have a very large dataset that is given like this

[TABLE="width: 2216"]
<colgroup><col><col><col span="2"><col><col><col span="4"><col><col><col span="4"><col></colgroup><tbody>[TR]
[TD]Name[/TD]
[TD]Manager[/TD]
[TD]Trainer[/TD]
[TD]Department[/TD]
[TD]Start Date[/TD]
[TD="colspan: 6"]System 1[/TD]
[TD="colspan: 6"]System 2[/TD]
[/TR]
[TR]
[TD]Score[/TD]
[TD]Passed/Failed[/TD]
[TD]Score [/TD]
[TD]Passed/Failed[/TD]
[TD]Score[/TD]
[TD]Passed/Failed[/TD]
[TD]Score[/TD]
[TD]Passed/Failed[/TD]
[TD]Score [/TD]
[TD]Passed/Failed[/TD]
[TD]Score[/TD]
[TD]Passed/Failed[/TD]
[/TR]
[TR]
[TD]Elizabeth Bayes[/TD]
[TD]Louise Raisin[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]10/10/2016[/TD]
[TD]80[/TD]
[TD]Failed[/TD]
[TD]100[/TD]
[TD]Passed[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]67[/TD]
[TD]Failed[/TD]
[TD]100[/TD]
[TD]Passed[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]Luke Fitzroy-Smith[/TD]
[TD]Mo Clay[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]10/10/2016[/TD]
[TD]95[/TD]
[TD]Passed[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD]100[/TD]
[TD]Passed[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]Jessica Handley[/TD]
[TD]Alison Blood / Tom Peel[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]10/10/2016[/TD]
[TD]100[/TD]
[TD]Passed[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD]100[/TD]
[TD]Passed[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
</tbody>[/TABLE]


Row 1 has the system name (Column F, then L) depending on how many systems they are etc as its merged
Row 2 has the field names
Row 3 to end row has the data

I need to transpose all this data so it looks like this

[TABLE="width: 1170"]
<colgroup><col><col span="3"><col><col><col span="2"><col><col></colgroup><tbody>[TR]
[TD]Name[/TD]
[TD]Manager[/TD]
[TD]Trainer[/TD]
[TD]Department[/TD]
[TD]Start Date[/TD]
[TD]Metric[/TD]
[TD]Attempt[/TD]
[TD]Type[/TD]
[TD]Score[/TD]
[TD]Passed/Failed[/TD]
[/TR]
[TR]
[TD]Elizabeth Bayes[/TD]
[TD]Louise Raisin[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]10/10/2016[/TD]
[TD]Sheet Name[/TD]
[TD]1stAttempt[/TD]
[TD]System 1[/TD]
[TD]80[/TD]
[TD]Failed[/TD]
[/TR]
[TR]
[TD]Elizabeth Bayes[/TD]
[TD]Louise Raisin[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]10/10/2016[/TD]
[TD]Sheet Name[/TD]
[TD]2nd Attempt[/TD]
[TD]System 1[/TD]
[TD]100[/TD]
[TD]Passed[/TD]
[/TR]
[TR]
[TD]Elizabeth Bayes[/TD]
[TD]Louise Raisin[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]10/10/2016[/TD]
[TD]Sheet Name[/TD]
[TD]1stAttempt[/TD]
[TD]System 2[/TD]
[TD]67[/TD]
[TD]Failed[/TD]
[/TR]
[TR]
[TD]Elizabeth Bayes[/TD]
[TD]Louise Raisin[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]10/10/2016[/TD]
[TD]Sheet Name[/TD]
[TD]2nd Attempt[/TD]
[TD]System 2[/TD]
[TD]100[/TD]
[TD]Passed[/TD]
[/TR]
[TR]
[TD]Luke Fitzroy-Smith[/TD]
[TD]Mo Clay[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]10/10/2016[/TD]
[TD]Sheet Name[/TD]
[TD]1stAttempt[/TD]
[TD]System 1[/TD]
[TD]95[/TD]
[TD]Passed[/TD]
[/TR]
[TR]
[TD]Luke Fitzroy-Smith[/TD]
[TD]Mo Clay[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]10/10/2016[/TD]
[TD]Sheet Name[/TD]
[TD]1stAttempt[/TD]
[TD]System 2[/TD]
[TD]100[/TD]
[TD]Passed[/TD]
[/TR]
</tbody>[/TABLE]

Here is the scenario

I have a list of agents where they have different systems they are being tested on (i have 2 sheets to loop through but each sheet could differ in terms of how many systems they are being tested on)

Each agent has 3 attempts to pass per system (some may take 1 attempt, some 2 and some 3)

I need to list and transpose the data so it appears like above (Where i have put sheet name is going to be the sheet name i am currently looping through

I hope this makes sense
 

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.
Sort by date Sort by votes
Maybe this will work

Code: 
Sub Test()


Dim scoreRange As Range
Dim nameRange As Range


OnRow = 3
myRng = Cells(Rows.Count, "A").End(xlUp).Row


For i = 3 To myRng


        Set scoreRange = Range("F" & OnRow & ":P" & OnRow)
        Set nameRange = Range("A" & OnRow & ":E" & OnRow)
        
        For Each c In scoreRange
        
            If c.Value <> "" And c.Value <> Empty And c.Value <> "Passed" And c.Value <> "Failed" Then
            myRng2 = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1
            
            Sheets("Sheet2").Range("A" & myRng2).Value = Sheets("Sheet1").Range("A" & OnRow).Value
            Sheets("Sheet2").Range("B" & myRng2).Value = Sheets("Sheet1").Range("B" & OnRow).Value
            Sheets("Sheet2").Range("C" & myRng2).Value = Sheets("Sheet1").Range("C" & OnRow).Value
            Sheets("Sheet2").Range("D" & myRng2).Value = Sheets("Sheet1").Range("D" & OnRow).Value
            Sheets("Sheet2").Range("E" & myRng2).Value = Sheets("Sheet1").Range("E" & OnRow).Value
            
            Sheets("Sheet2").Range("F" & myRng2).Value = ActiveSheet.Name
            Sheets("Sheet2").Range("I" & myRng2).Value = Sheets("Sheet1").Range(c.Address).Value
            Sheets("Sheet2").Range("J" & myRng2).Value = Sheets("Sheet1").Range(c.Address).Offset(rowOffset:=0, ColumnOffset:=1).Value
            
            Select Case Left(c.Address, 2)
                Case "$F"
                    attempt = "1st Attempt"
                    myType = "System 1"
                Case "$H"
                    attempt = "2nd Attempt"
                    myType = "System 1"
                Case "$J"
                    attempt = "3rd Attempt"
                    myType = "System 1"
                Case "$L"
                    attempt = "1st Attempt"
                    myType = "System 2"
                Case "$N"
                    attempt = "2nd Attempt"
                    myType = "System 2"
                Case "$P"
                    attempt = "3rd Attempt"
                    myType = "System 2"
            End Select
            
            Sheets("Sheet2").Range("G" & myRng2).Value = attempt
            Sheets("Sheet2").Range("H" & myRng2).Value = myType
            
            End If
                   
        
        Next c
        
        OnRow = OnRow + 1


Next i


End Sub
 
Upvote 0
Hi - This does work brill thank you but needs a couple of tweaks

1) You've hard coded the columns so it looks up until column P But i need to loop through another 2 sheets so they could have more types so could end up with column V or AB
2) The system name has been hard coded in but it needs to come from cell F1, L1, R1 etc (Cells are merged)
3) the last row will change depending on what sheet im looping through - the format is all the same except there could be more types and more rows - The sheet names i need to loop through are called Type1, Type2 and Type3

Coding4Fun said:
Maybe this will work

Code: 
Sub Test()


Dim scoreRange As Range
Dim nameRange As Range


OnRow = 3
myRng = Cells(Rows.Count, "A").End(xlUp).Row


For i = 3 To myRng


        Set scoreRange = Range("F" & OnRow & ":P" & OnRow)
        Set nameRange = Range("A" & OnRow & ":E" & OnRow)
        
        For Each c In scoreRange
        
            If c.Value <> "" And c.Value <> Empty And c.Value <> "Passed" And c.Value <> "Failed" Then
            myRng2 = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1
            
            Sheets("Sheet2").Range("A" & myRng2).Value = Sheets("Sheet1").Range("A" & OnRow).Value
            Sheets("Sheet2").Range("B" & myRng2).Value = Sheets("Sheet1").Range("B" & OnRow).Value
            Sheets("Sheet2").Range("C" & myRng2).Value = Sheets("Sheet1").Range("C" & OnRow).Value
            Sheets("Sheet2").Range("D" & myRng2).Value = Sheets("Sheet1").Range("D" & OnRow).Value
            Sheets("Sheet2").Range("E" & myRng2).Value = Sheets("Sheet1").Range("E" & OnRow).Value
            
            Sheets("Sheet2").Range("F" & myRng2).Value = ActiveSheet.Name
            Sheets("Sheet2").Range("I" & myRng2).Value = Sheets("Sheet1").Range(c.Address).Value
            Sheets("Sheet2").Range("J" & myRng2).Value = Sheets("Sheet1").Range(c.Address).Offset(rowOffset:=0, ColumnOffset:=1).Value
            
            Select Case Left(c.Address, 2)
                Case "$F"
                    attempt = "1st Attempt"
                    myType = "System 1"
                Case "$H"
                    attempt = "2nd Attempt"
                    myType = "System 1"
                Case "$J"
                    attempt = "3rd Attempt"
                    myType = "System 1"
                Case "$L"
                    attempt = "1st Attempt"
                    myType = "System 2"
                Case "$N"
                    attempt = "2nd Attempt"
                    myType = "System 2"
                Case "$P"
                    attempt = "3rd Attempt"
                    myType = "System 2"
            End Select
            
            Sheets("Sheet2").Range("G" & myRng2).Value = attempt
            Sheets("Sheet2").Range("H" & myRng2).Value = myType
            
            End If
                   
        
        Next c
        
        OnRow = OnRow + 1


Next i


End Sub
Click to expand...
 
Upvote 0
Siyanna,

Thanks for the two Private Messages.

It would help if we could see your actual raw data workbook/worksheets, and, what the results (manually formatted by you) should look like.

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
 
Upvote 0
Thank you so much Hiker for getting back to me - it looks like coding4funs code does the trick but needs a few tweaks so the columns, type name and lastrow is not hard coded
 
Upvote 0
Siyanna said:
Thank you so much Hiker for getting back to me - it looks like coding4funs code does the trick but needs a few tweaks so the columns, type name and lastrow is not hard coded
Click to expand...

Siyanna,

You are very welcome.

I am sure that Coding4Fun will be able to solve your request.
 
Upvote 0
Hi Again, i managed to figure out the issue to include 0 values and also added some code that loops through the worksheets

I just need to get around the type and not hard code it to col P and amend to the amount of types there is in that worksheet and also the typename needs to change and not hard coded (at the minute i have included the typename but this could extent depending on the more types there are on the sheet im looking at)

here is the amended code (My sheet that im pasting it to has a table so im deleting the data each time i run this code)

Code: 
Sub TransposeMyData()


Dim scoreRange As Range
Dim nameRange As Range
Dim OnRow As Long
Dim myRng As Long
Dim myRng2 As Long
Dim ActWs As Worksheet
Dim CleanUpSh As Worksheet
Dim LookUpSh As Worksheet
Dim tbTable As ListObject
    
Set CleanUpSh = Worksheets("CleanUp")
Set LookUpSh = Worksheets("LookUp")


Set tbTable = CleanUpSh.ListObjects("Data")
If Not tbTable.DataBodyRange Is Nothing Then tbTable.DataBodyRange.Delete


myRng2 = CleanUpSh.Range("A:A").Find(WHat:="*", After:=CleanUpSh.Range("A1"), SearchDirection:=xlPrevious).Offset(1).Row


For shLoop = 4 To LookUpSh.Range("B" & Rows.Count).End(xlUp).Row
    Set ActWs = Worksheets(LookUpSh.Range("B" & shLoop).Value)
    myRng = ActWs.Cells(ActWs.Rows.Count, "A").End(xlUp).Row
    OnRow = 3
        For i = 3 To myRng
            With ActWs
                Set scoreRange = .Range("F" & OnRow & ":P" & OnRow)
                Set nameRange = .Range("A" & OnRow & ":E" & OnRow)
                
                For Each c In scoreRange
                   
                    If c.Value <> "" And c.Value <> "Passed" And c.Value <> "Failed" Then
                        myRng2 = CleanUpSh.Range("A:A").Find(WHat:="*", After:=CleanUpSh.Range("A1"), SearchDirection:=xlPrevious).Offset(1).Row
                        
                        CleanUpSh.Range("A" & myRng2).Value = .Range("A" & OnRow).Value
                        CleanUpSh.Range("B" & myRng2).Value = .Range("B" & OnRow).Value
                        CleanUpSh.Range("C" & myRng2).Value = .Range("C" & OnRow).Value
                        CleanUpSh.Range("D" & myRng2).Value = .Range("D" & OnRow).Value
                        CleanUpSh.Range("E" & myRng2).Value = .Range("E" & OnRow).Value
                        
                        CleanUpSh.Range("F" & myRng2).Value = .Name
                        CleanUpSh.Range("I" & myRng2).Value = .Range(c.Address).Value
                        CleanUpSh.Range("J" & myRng2).Value = .Range(c.Address).Offset(rowOffset:=0, ColumnOffset:=1).Value
                        
                        Select Case Left(c.Address, 2)
                            Case "$F"
                                attempt = "1st Attempt"
                                myType = .Range("F1").Value
                            Case "$H"
                                attempt = "2nd Attempt"
                                myType = .Range("F1").Value
                            Case "$J"
                                attempt = "3rd Attempt"
                                myType = .Range("F1").Value
                            Case "$L"
                                attempt = "1st Attempt"
                                myType = .Range("L1").Value
                            Case "$N"
                                attempt = "2nd Attempt"
                                myType = .Range("L1").Value
                            Case "$P"
                                attempt = "3rd Attempt"
                                myType = .Range("L1").Value
                        End Select
                        
                        CleanUpSh.Range("G" & myRng2).Value = attempt
                        CleanUpSh.Range("H" & myRng2).Value = myType
                    End If
                Next c
                OnRow = OnRow + 1
            End With
        Next i
Next shLoop


End Sub



Siyanna said:
Hi - This does work brill thank you but needs a couple of tweaks

1) You've hard coded the columns so it looks up until column P But i need to loop through another 2 sheets so they could have more types so could end up with column V or AB
2) The system name has been hard coded in but it needs to come from cell F1, L1, R1 etc (Cells are merged)
3) the last row will change depending on what sheet im looping through - the format is all the same except there could be more types and more rows - The sheet names i need to loop through are called Type1, Type2 and Type3
Click to expand...
 
Last edited:
Upvote 0
I might need to re-write this, no solution is jumping out at me at the moment to rewrite this cleanly using the previous format.

The column P issue:

This is coded here
Code: 
'F to P are the scores to check and move, you can adjust this out as far as needed.
Set scoreRange = .Range("F" & OnRow & ":P" & OnRow)

Set scoreRange = .Range("F" & OnRow & ":[COLOR=#ff0000]AU[/COLOR]" & OnRow)

Code: 
Select Case Left(c.Address, 2)
    Case "$F"
        attempt = "1st Attempt"
        myType = .Range("F1").Value
    Case "$H"
        attempt = "2nd Attempt"
        myType = .Range("F1").Value
    Case "$J"
        attempt = "3rd Attempt"
        myType = .Range("F1").Value
    Case "$L"
        attempt = "1st Attempt"
        myType = .Range("L1").Value
    Case "$N"
        attempt = "2nd Attempt"
        myType = .Range("L1").Value
    Case "$P"
        attempt = "3rd Attempt"
        myType = .Range("L1").Value
[B]    Case "$R"
        attempt = "1st Attempt"
        myType = .Range("R1").Value
    Case "$T"
        attempt = "2nd Attempt"
        myType = .Range("R1").Value
    Case "$V"
        attempt = "3rd Attempt"
        myType = .Range("R1").Value
    Case "$X"
        attempt = "1st Attempt"
        myType = .Range("X1").Value
    Case "$Z"
        attempt = "2nd Attempt"
        myType = .Range("X1").Value
    Case "$AB"
        attempt = "3rd Attempt"
        myType = .Range("X1").Value[/B]
                        End Select


It looks like you also addressed the issue of the last row changing for each sheet with this line

Code: 
myRng = ActWs.Cells(ActWs.Rows.Count, "A").End(xlUp).Row
 
Last edited:
Upvote 0
Coding4Fun said:
I might need to re-write this, no solution is jumping out at me at the moment to rewrite this cleanly using the previous format.

The column P issue:

This is coded here
Code: 
'F to P are the scores to check and move, you can adjust this out as far as needed.
Set scoreRange = .Range("F" & OnRow & ":P" & OnRow)

Set scoreRange = .Range("F" & OnRow & ":[COLOR=#ff0000]AU[/COLOR]" & OnRow)

Code: 
Select Case Left(c.Address, 2)
    Case "$F"
        attempt = "1st Attempt"
        myType = .Range("F1").Value
    Case "$H"
        attempt = "2nd Attempt"
        myType = .Range("F1").Value
    Case "$J"
        attempt = "3rd Attempt"
        myType = .Range("F1").Value
    Case "$L"
        attempt = "1st Attempt"
        myType = .Range("L1").Value
    Case "$N"
        attempt = "2nd Attempt"
        myType = .Range("L1").Value
    Case "$P"
        attempt = "3rd Attempt"
        myType = .Range("L1").Value
[B]    Case "$R"
        attempt = "1st Attempt"
        myType = .Range("R1").Value
    Case "$T"
        attempt = "2nd Attempt"
        myType = .Range("R1").Value
    Case "$V"
        attempt = "3rd Attempt"
        myType = .Range("R1").Value
    Case "$X"
        attempt = "1st Attempt"
        myType = .Range("X1").Value
    Case "$Z"
        attempt = "2nd Attempt"
        myType = .Range("X1").Value
    Case "$AB"
        attempt = "3rd Attempt"
        myType = .Range("X1").Value[/B]
                        End Select


It looks like you also addressed the issue of the last row changing for each sheet with this line

Code: 
myRng = ActWs.Cells(ActWs.Rows.Count, "A").End(xlUp).Row
Click to expand...


Hi

thank you - i thought about doing that by extending the range and also the select case statement but didnt know how robust it will be and also on some sheets - it may only need to go to be therefore it would have been looking at more columns than needed so i guess - this change should would work but could be tweaked to make it more robust

i appreciate your help
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
Calendar form cancel button passing data to worksheet
Replies
7
Views
1K
AndyEd
A
M
  • Question Question
Help with FilterXML formula
Replies
0
Views
2K
montex01
M
L
  • Question Question
VBA works on work PC but not home PC
Replies
3
Views
2K
rollis13
rollis13
L
  • Question Question
conditional formatting - like reverse lookup
Replies
3
Views
826
Fluff
Fluff
J
  • Question Question
Anyone can optimize these lookup / sumifs ?
Replies
4
Views
848
JumboCactuar
J

Forum statistics

Threads
1,224,823
Messages
6,181,177
Members
453,021
Latest member
Justyna P

Share this page

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