Data Transposing with matching formatting and column headings

[twinwings]

Hello,

I am having some difficulty wrapping my head around this.

I know I can get a rough solution via pivot tables but I would like to explore the vba route as well.



I am looking for a macro that would take the following table from sheet1

Name	hair	nose	eyes	ears
Donald	high	medium	low	na
Trump	low	na	medium	high

<tbody>
</tbody>

Where:
- High = red filled cell
- Medium = yellow filled cell
- Low = green filled cell
- na = no fill


And do the following

1) Transpose the data in another sheet, called sheet2
2) Instead of taking the "high/medium/low/na", the macro take the column headings such as "hair, nose, eyes, ears" and posts it beside the name
3) For the column in sheet2 that includes the column headings from sheet1, the column in sheet2 should say the headings in sheet1, by matching the color fill of the category.
eg. Hair - Donald, will have a red filled cell for "Hair" as it falls under "high" which is a red filled cell in sheet1.
eg. Eyes - Trump, will have a yellow filled cell for "Eyes" as it falls under "medium" which is a yellow filled cell in sheet 1.

The "solution" would look something like this

Category	Name
hair (red fill)	Donald
nose (yellow fill)	Donald
eyes ( green fill)	Donald
hair (green fill)	Trump
eyes (yellow fill)	Trump
ears (red fill)	Trump

<tbody>
</tbody>

Note there's no Ears for Donald or Nose for Trump as they are both "na" and should not show up on sheet 2.


From what I saw, there's a lot of ways I can transpose, but I can't seem to find a transposition which takes the column headings instead of the data under the column headings while also omitting the data under the column headings (and omitting certain columns all together eg. if "na").


Any help is greatly appreciated.

 

[Rijnsent]

Hi twinwings,
this code should be more or less what you're looking for:

Sub transpose1()

Set Sht1 = Worksheets("Sheet1")
Set Sht2 = Worksheets("Sheet2")

r2 = 2
For r1 = 2 To 3
    For c1 = 2 To 6
        'Check for pattern: https://docs.microsoft.com/en-us/office/vba/api/excel.xlpattern
        Debug.Print Sht1.Cells(r1, c1).Interior.Color, Sht1.Cells(r1, c1).Interior.ColorIndex, Sht1.Cells(r1, c1).Interior.Pattern
        If Sht1.Cells(r1, c1).Interior.Pattern = xlPatternSolid And Sht1.Cells(r1, c1).Interior.Color <> 16777215 Then
            'Has color, not white, do something
            Sht2.Cells(r2, 1).Value = Sht1.Cells(1, c1).Value
            Sht2.Cells(r2, 1).Interior.Color = Sht1.Cells(r1, c1).Interior.Color
            Sht2.Cells(r2, 2).Value = Sht1.Cells(r1, 1).Value
            r2 = r2 + 1
        End If
    Next c1
Next r1

End Sub

Cheers,
Koen

 

[twinwings]

Thank you Koen, and my sincere apologies for the delay.


Your code does indeed work great but I am having some trouble "relocating" the code procedure to a different example where the NAME column is column B; and hair/nose/eyes/ears are columns I to L of Sheet1

Name (column B)	hair (column I)	nose (column J)	eyes (column K)	ears (eyes (column L)
Donald (Cell B12)	high	medium	low	na
Trump	low	na	medium	high

<tbody>
</tbody>

and convert the above table into this in sheet2, but instead of starting at row 2, it starts at row11

Category (but starting at cell A11 as opposed to A2)	Name (but starting at cell B11 as opposed to B2)
hair (red fill)	Donald
nose (yellow fill)	Donald
eyes ( green fill)	Donald
hair (green fill)	Trump
eyes (yellow fill)	Trump
ears (red fill)	Trump

<tbody>
</tbody>

Here's what I have so far...but I can't seem to crack it


Sub transpose4()


Set Sht1 = Worksheets("Sheet1")
Set Sht2 = Worksheets("Sheet2")



r2 = 11
For r1 = 12 To 126 'r1 begins from row 12 to 126
'This selects length of names from tab1 to next tab.
For c1 = 9 To 12 'columbs b to g
Debug.Print Sht1.Cells(r1, c1).Interior.Color, Sht1.Cells(r1, c1).Interior.ColorIndex, Sht1.Cells(r1, c1).Interior.Pattern
If Sht1.Cells(r1, c1).Interior.Pattern = xlPatternSolid And Sht1.Cells(r1, c1).Interior.Color <> 16777215 Then
'if color not white, do something
Sht2.Cells(r2, 1).Value = Sht1.Cells(11, c1).Value
' first cell in row 2, column 1 in sheet2, is equal to the cell in first row, but starting count column in sheet1
Sht2.Cells(r2, 1).Interior.Color = Sht1.Cells(r1, c1).Interior.Color
' first cell in row 2, column 1 in sheet2, is equal to the cell color in first row which is actual row 2, but starting count column in sheet1
Sht2.Cells(r2, 2).Value = Sht1.Cells(r1, 2).Value
r2 = r2 + 1
End If
Next c1
Next r1


End Sub

 

[Rijnsent]

Hi twinwings,
check out the line that says: r2 = 11 (just before the loop). That's the row that's used to put the results. So change that to r2=2 to start your results on row 2.
Cheers,
Koen

 

[twinwings]

Hi twinwings,
check out the line that says: r2 = 11 (just before the loop). That's the row that's used to put the results. So change that to r2=2 to start your results on row 2.
Cheers,
Koen

Thank you for respoding Koen, but I can't seem to get it to work.

Just to clarify, your first code you sent works perfectly.

I am just trying to change where the data is located, and where it will be transposed to.

If my data in sheet1 looks like so (where there could be 100s of rows)

Column B	C	D	E	F	G	H	Column I	Column J	Column K	Column L
Name							hair	nose	eyes	ears
Donald							high	medium	low	na
Trump							low	na	medium	high

<tbody>
</tbody>

how can I convert this so it does this in sheet2

Row1 Column A	Row1 Column B
2
3
4
5
6
7
8
9
Category (this heading is preset)	Name(this heading is preset)
hair (red fill)	Donald
nose (yellow fill)	Donald
eyes ( green fill)	Donald
hair (green fill)	Trump
eyes (yellow fill)	Trump
ears (red fill)	Trump

<tbody>
</tbody>

Essentially, the transposed output in sheet 2 will begin in row 11(columnA) as opposed to row 2 from my first request.

 

[twinwings]

Hi twinwings,
check out the line that says: r2 = 11 (just before the loop). That's the row that's used to put the results. So change that to r2=2 to start your results on row 2.
Cheers,
Koen

Hi Koen,

So this code does exactly what I need it to do

Sub transpose1()


Set Sht1 = Worksheets("Sheet1")
Set Sht2 = Worksheets("Sheet2")


r2 = 11
For r1 = 12 To 136 'r1 begins from row 2 to 126
'This selects length of names from tab1 to next tab.
For c1 = 9 To 13 'columbs b to g
Debug.Print Sht1.Cells(r1, c1).Interior.Color, Sht1.Cells(r1, c1).Interior.ColorIndex, Sht1.Cells(r1, c1).Interior.Pattern
If Sht1.Cells(r1, c1).Interior.Pattern = xlPatternSolid And Sht1.Cells(r1, c1).Interior.Color <> 16777215 Then
'if color not white, do something
Sht2.Cells(r2, 1).Value = Sht1.Cells(11, c1).Value
' first cell in row 2, column 1 in sheet2, is equal to the cell in first row, but starting count column in sheet1
Sht2.Cells(r2, 1).Interior.Color = Sht1.Cells(r1, c1).Interior.Color
' first cell in row 2, column 1 in sheet2, is equal to the cell color in first row which is actual row 2, but starting count column in sheet1
Sht2.Cells(r2, 2).Value = Sht1.Cells(r1, 2).Value
r2 = r2 + 1
End If
Next c1
Next r1


End Sub



However, although it can grab solid colours, it cannot grab conditional formatting? How can I make the highlighted line grab the conditional formatting.

 

[Rijnsent]

Hi twinwings,
I found this question online: https://stackoverflow.com/questions...m-a-conditional-formatting-in-excel-using-vba
You see the first answer comes up with "If you want to know the color of a cell that has been colored by a conditional formatting rule (CFR) then use .Range.DisplayFormat.Interior.Color¹."

So in your case:
Sht1.Cells(r1, c1).Interior.Color -> Sht1.Cells(r1, c1).DisplayFormat.Interior.Color
And
Sht1.Cells(r1, c1).Interior.Pattern -> Sht1.Cells(r1, c1).DisplayFormat.Interior.Pattern

That should do the trick.

Cheers,
Koen
P.S. If you paste your code here, please use the CODE tags, see my signature.

 

[twinwings]

Hi Koen,

Thank you so much for your help.

I thought it was more do to with "xlPatternAutomatic" but couldn't get anywhere.

It seems the below code finally does what I want it to do.

Thank you so much,

Sub transpose1()


Set Sht1 = Worksheets("Sheet1")
Set Sht2 = Worksheets("Sheet2")


r2 = 11
For r1 = 12 To 136 'r1 begins from row 2 to 126
'This selects length of names from tab1 to next tab.
    For c1 = 9 To 13 'columbs b to g
        Debug.Print Sht1.Cells(r1, c1).DisplayFormat.Interior.Color, Sht1.Cells(r1, c1).DisplayFormat.Interior.ColorIndex, Sht1.Cells(r1, c1).DisplayFormat.Interior.Pattern
        If Sht1.Cells(r1, c1).DisplayFormat.Interior.Pattern = xlPatternSolid And Sht1.Cells(r1, c1).DisplayFormat.Interior.Color <> 16777215 Then
            'if color not white, do something
            Sht2.Cells(r2, 1).Value = Sht1.Cells(11, c1).Value
            ' first cell in row 2, column 1 in sheet2, is equal to the cell in first row, but starting count column in sheet1
            Sht2.Cells(r2, 1).Interior.Color = Sht1.Cells(r1, c1).DisplayFormat.Interior.Color
            ' first cell in row 2, column 1 in sheet2, is equal to the cell color in first row which is actual row 2, but starting count column in sheet1
            Sht2.Cells(r2, 2).Value = Sht1.Cells(r1, 2).Value
            r2 = r2 + 1
        End If
    Next c1
Next r1


End Sub