Transpose from multiple columns to set rows based on criteria

[greatbacon]

I am a long time lurker of the site and I am finally stuck and need some help. I don't even know how to even phrase my problem to search it in google. My data looks as follows:

A

B

C

D

E

F

G

H

I

J

...

ES

ET

EU

Name

Q1

Q2

Q3

Q1-2

Q2-2

Q3-2

Q1-3

Q2-3

Q3-3

...

Q1-49

Q2-49

Q3-49

Smith, Bob

text

text

text

text

text

text

text

text

text

...

Doe, Jane

text

text

text

...

<tbody>
</tbody>

I am looking for:

A	B	C	D
Name	Q1	Q2	Q3
Smith, Bob	text	text	text
	text	text	text
	text	text	text
Doe, Jane	text	text	text

<tbody>
</tbody>

Q1 2 and 3 are repeated 49 times because they are responses to one question, just stored in grid format. Some respondents filled in 49 responses, most only 2 or 3. If they "responded" then they had to have something in Q1 Q2 Q3. There were no respondents with an answer in Q1 but not Q2 or Q3.

I am looking for a stacked output with blanks in the name fields until the next respondent is reached. I will be outputting this via a merge and my data is unwieldy in its current form. Please help me wizards, I am using Excel 2013.

Thank You!!

 

[greatbacon]

Please help! I am still stuck!

 

[onlyadrafter]

Hello,

does this work as required?

Sub COLUMNS_TO_ROWS()
    Application.ScreenUpdating = False
    With Sheets("Sheet1")
        For MY_ROWS = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
            MY_NAME = .Range("A" & MY_ROWS).Value
                For MY_COLS = 2 To 197 Step 3
                    If Not IsEmpty(Cells(MY_ROWS, MY_COLS).Value) Then
                        .Range(Cells(MY_ROWS, MY_COLS), Cells(MY_ROWS, MY_COLS + 2)).Copy
                        With Sheets("Sheet2")
                            .Range("B" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteAll)
                            .Range("B" & .Rows.Count).End(xlUp).Offset(0, -1).Value = MY_NAME
                            MY_NAME = ""
                        End With
                    End If
                Next MY_COLS
        Next MY_ROWS
    End With
    Application.ScreenUpdating = True
End Sub

 

[greatbacon]

I love you, will you marry me? Worked great it appears.

 

[onlyadrafter]

Hello,

further to your question in a PM (just post it here, so others can see it).

This code will combine all answers, it won't leave out repeat answers. Will the answers ever be like,

CAT, DOG, DOG, CAT

If so, this would require a further routine.

Or will the answers, once duplicated, never have a different answer i.e.

CAT, DOG, DOG, DOG?

Sub COLUMNS_TO_ROWS_2()
    Application.ScreenUpdating = False
    With Sheets("Sheet1")
        For MY_ROWS = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
            MY_NAME = .Range("A" & MY_ROWS).Value
                For MY_COLS = 2 To 197 Step 3
                    If Not IsEmpty(Cells(MY_ROWS, MY_COLS).Value) Then
                        If MY_Q1 = "" Then
                            MY_Q1 = Cells(MY_ROWS, MY_COLS).Value
                        Else
                            MY_Q1 = MY_Q1 & " , " & Cells(MY_ROWS, MY_COLS).Value
                        End If
                        If MY_Q2 = "" Then
                            MY_Q2 = Cells(MY_ROWS, MY_COLS).Value
                        Else
                            MY_Q2 = MY_Q2 & " , " & Cells(MY_ROWS, MY_COLS + 1).Value
                        End If
                        If MY_Q3 = "" Then
                            MY_Q3 = Cells(MY_ROWS, MY_COLS).Value
                        Else
                            MY_Q3 = MY_Q3 & " , " & Cells(MY_ROWS, MY_COLS + 2).Value
                        End If
                    End If
                Next MY_COLS
                With Sheets("Sheet2")
                    .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Value = MY_NAME
                    .Range("B" & .Rows.Count).End(xlUp).Offset(1, 0).Value = MY_Q1
                    .Range("C" & .Rows.Count).End(xlUp).Offset(1, 0).Value = MY_Q2
                    .Range("D" & .Rows.Count).End(xlUp).Offset(1, 0).Value = MY_Q3
                    MY_Q1 = ""
                    MY_Q2 = ""
                    MY_Q3 = ""
                End With
        Next MY_ROWS
    End With
    Application.ScreenUpdating = True
End Sub

will need to look at this later. Need to be somewhere else soon.

 

[greatbacon]

A is name, b is company name, c is type of financial involvement, and d is persons involved. I only want to combine and add commas if both c and d match for each unique a. B would then be combined with a comma while c and d remain the same. Would it be easier to see my output of your original code?

For example if john smith received consulting fees from 4 companies currently he has four lines where column c and d match perfectly and b has different company names. Ideally, I am looking for those different answers in column b to be combined with commas and the rest to stay the way it is.

Thank you!!

 

[greatbacon]

Hello,

further to your question in a PM (just post it here, so others can see it).

This code will combine all answers, it won't leave out repeat answers. Will the answers ever be like,

CAT, DOG, DOG, CAT

If so, this would require a further routine.

Or will the answers, once duplicated, never have a different answer i.e.

CAT, DOG, DOG, DOG?

Sub COLUMNS_TO_ROWS_2()
    Application.ScreenUpdating = False
    With Sheets("Sheet1")
        For MY_ROWS = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
            MY_NAME = .Range("A" & MY_ROWS).Value
                For MY_COLS = 2 To 197 Step 3
                    If Not IsEmpty(Cells(MY_ROWS, MY_COLS).Value) Then
                        If MY_Q1 = "" Then
                            MY_Q1 = Cells(MY_ROWS, MY_COLS).Value
                        Else
                            MY_Q1 = MY_Q1 & " , " & Cells(MY_ROWS, MY_COLS).Value
                        End If
                        If MY_Q2 = "" Then
                            MY_Q2 = Cells(MY_ROWS, MY_COLS).Value
                        Else
                            MY_Q2 = MY_Q2 & " , " & Cells(MY_ROWS, MY_COLS + 1).Value
                        End If
                        If MY_Q3 = "" Then
                            MY_Q3 = Cells(MY_ROWS, MY_COLS).Value
                        Else
                            MY_Q3 = MY_Q3 & " , " & Cells(MY_ROWS, MY_COLS + 2).Value
                        End If
                    End If
                Next MY_COLS
                With Sheets("Sheet2")
                    .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Value = MY_NAME
                    .Range("B" & .Rows.Count).End(xlUp).Offset(1, 0).Value = MY_Q1
                    .Range("C" & .Rows.Count).End(xlUp).Offset(1, 0).Value = MY_Q2
                    .Range("D" & .Rows.Count).End(xlUp).Offset(1, 0).Value = MY_Q3
                    MY_Q1 = ""
                    MY_Q2 = ""
                    MY_Q3 = ""
                End With
        Next MY_ROWS
    End With
    Application.ScreenUpdating = True
End Sub

will need to look at this later. Need to be somewhere else soon.

I was able to run this a little while ago and my output is strange, it looks like the same data is present in each row in columns B,C,and D. Would it help to see my data?

 

[onlyadrafter]

Hello,

does this work as expected?

Sub COLUMNS_TO_ROWS_2()
    Application.ScreenUpdating = False
    With Sheets("Sheet1")
        For MY_ROWS = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
            MY_NAME = .Range("A" & MY_ROWS).Value
                For MY_COLS = 2 To 197 Step 3
                    If Not IsEmpty(Cells(MY_ROWS, MY_COLS).Value) Then
                        If MY_Q1 = "" Then
                            MY_Q1 = Cells(MY_ROWS, MY_COLS).Value
                        Else
                            If Cells(MY_ROWS, MY_COLS).Value <> Cells(MY_ROWS, MY_COLS - 3).Value Then
                                MY_Q1 = MY_Q1 & ", " & Cells(MY_ROWS, MY_COLS).Value
                            End If
                        End If
                        If MY_Q2 = "" Then
                            MY_Q2 = Cells(MY_ROWS, MY_COLS + 1).Value
                        Else
                            If Cells(MY_ROWS, MY_COLS + 1).Value <> Cells(MY_ROWS, MY_COLS - 2).Value Then
                                MY_Q2 = MY_Q2 & ", " & Cells(MY_ROWS, MY_COLS + 1).Value
                            End If
                        End If
                        If MY_Q3 = "" Then
                            MY_Q3 = Cells(MY_ROWS, MY_COLS + 2).Value
                        Else
                            If Cells(MY_ROWS, MY_COLS + 2).Value <> Cells(MY_ROWS, MY_COLS - 1).Value Then
                                MY_Q3 = MY_Q3 & ", " & Cells(MY_ROWS, MY_COLS + 2).Value
                            End If
                        End If
                    End If
                Next MY_COLS
                With Sheets("Sheet2")
                    .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Value = MY_NAME
                    .Range("B" & .Rows.Count).End(xlUp).Offset(1, 0).Value = MY_Q1
                    .Range("C" & .Rows.Count).End(xlUp).Offset(1, 0).Value = MY_Q2
                    .Range("D" & .Rows.Count).End(xlUp).Offset(1, 0).Value = MY_Q3
                    MY_Q1 = ""
                    MY_Q2 = ""
                    MY_Q3 = ""
                End With
        Next MY_ROWS
    End With
    Application.ScreenUpdating = True
End Sub