transpose of 3 rows

[Fotis1991]

Hi

I have a "strange" isue in the Greek forum and i need help on this.

Op has 3 rows of data for the same person and needs to transpose all data for eatch person in a single row.

Any idea?

[jindon]

Try

Sub test()
    Dim a, i As Long, ii As Long, w, maxCol As Long
    Dim e, n As Long, x, txt As String
    With Range("a2").CurrentRegion
        a = .Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                txt = a(i, 1) & ";;" & a(i, 2)
                If Not .exists(txt) Then
                    ReDim w(1 To UBound(a, 2))
                    For ii = 1 To UBound(a, 2)
                        w(ii) = a(i, ii)
                    Next
                    .Item(txt) = w
                Else
                    w = .Item(txt)
                    ReDim Preserve w(1 To UBound(w) + 7)
                    For ii = 3 To UBound(a, 2)
                        w(UBound(w) - 10 + ii) = a(i, ii)
                    Next
                    .Item(txt) = w
                    maxCol = Application.Max(maxCol, UBound(w))
                End If
            Next
            For Each e In .keys
                w = .Item(e)
                If UBound(w) < maxCol Then
                    ReDim Preserve w(1 To maxCol)
                    .Item(e) = w
                End If
            Next
            x = .items: n = .Count
        End With
        With .Range("n2")
            .CurrentRegion.Offset(1).ClearContents
            .Resize(n, maxCol).Value = _
            Application.Transpose(Application.Transpose(x))
        End With
    End With
End Sub

[Fotis1991]

Thank you very mutch for this code but i know NOTHING at all, about VBA.

So i don't use VBA or Macro in my worksheets.

Let's hope that someone will have a formulae solution for this.

Once again, Thank you.

[rvasquez]

Hello there,

I understand the hesitation with using VBA and macros as they can be hard to understand but with this kind of request it might be a little easier to just add the code once to your worksheet and then be done with it. If you'd like I've provided a code below that has comments explaining what each line of code does and then instructions on how to use it in your workbook.

The code:

'declare variables
Dim c As Range, LR As String, mycol As Long, copytorow As Long, rng As Range
Dim AName As String

mycol = 10  'set the variable mycol equal to column 10 aka J
copytorow = 3   'set the variable copytorow to row 3

With Sheets(1)  'with the first worksheet in your workbook
    AName = .Range("A3").Value  'set AName = to the value that is in cell A3
    LR = .Range("A6555").End(xlUp).Row  'set LR equal to the last row in column A that contains a value
    
    For Each c In .Range("A4:A" & LR).Cells 'loop through cells in column A from row 4 to LR (defined as the last row in column A that contains a value)
                                            'now whenever c is used it is reference the current cell in the loop
        
        If c.Value = AName Then 'if the current cell in the loop is equal to Aname(defined on the first loop through as the value in cell A3) then
            .Range("C" & c.Row & ":I" & c.Row).Copy 'copy cells from column C to column I in the current cell in the loops row
                Cells(copytorow, mycol).PasteSpecial    'paste the copied cells to the column that is currently defined
                                                        'as the variable mycol and to the row that is currently defined as copyto row
                                                        'in the first loop through that will be cell J3
                    
                    'reset mycol to the last row in the copytorow +1,
                    'so mycol would go from being column J to column Q
                    mycol = .Range("IV" & copytorow).End(xlToLeft).Column + 1
                        
                        'set the variable range to rows that you are copying over so later you can delete them
                        If rng Is Nothing Then  'if rng is not set then
                            Set rng = .Rows(c.Row & ":" & c.Row)    'set rng equal to the current cell in the loop's row
                       
                        Else: Set rng = Union(rng, .Rows(c.Row & ":" & c.Row))  'if it is set add another row to the range
                        
                        End If
                    
        Else    'if the current cell in the loop is not equal to the variable Aname then
            mycol = 10  'reset mycol to 10 (column J)
            copytorow = c.Row   'reset myrow (to the current cell in the loops row)
            AName = c.Value 'reset Aname to the current cell in the loop's value
        End If
    
    Next c  'move to next cell in the loop

rng.Select  'select the cells whose row were added to rng
Selection.Delete shift:=xlUp    'delete the rows
End With

How to use it:

1. Move the worksheet you would like to format so that it is the first worksheet in your workbook then Press Alt+F8 on your keyboard (this will bring up the macro window)
2. Clear the macro name field and then type the word UniqueValues
3. That will be the name for the macro you are creating
4. Select the Create option
5. In between the Sub UniqueValues( ) and End Sub copy and paste the above code I provided you.

6. The entire code once you've copied and pasted should look like this:

Sub UniqueValues()  'macro UniqueValues

'declare variables
Dim c As Range, LR As String, mycol As Long, copytorow As Long, rng As Range
Dim AName As String

mycol = 10  'set the variable mycol equal to column 10 aka J
copytorow = 3   'set the variable copytorow to row 3

With Sheets(1)  'with the first worksheet in your workbook
    AName = .Range("A3").Value  'set AName = to the value that is in cell A3
    LR = .Range("A6555").End(xlUp).Row  'set LR equal to the last row in column A that contains a value
    
    For Each c In .Range("A4:A" & LR).Cells 'loop through cells in column A from row 4 to LR (defined as the last row in column A that contains a value)
                                            'now whenever c is used it is reference the current cell in the loop
        
        If c.Value = AName Then 'if the current cell in the loop is equal to Aname(defined on the first loop through as the value in cell A3) then
            .Range("C" & c.Row & ":I" & c.Row).Copy 'copy cells from column C to column I in the current cell in the loops row
                Cells(copytorow, mycol).PasteSpecial    'paste the copied cells to the column that is currently defined
                                                        'as the variable mycol and to the row that is currently defined as copyto row
                                                        'in the first loop through that will be cell J3
                    
                    'reset mycol to the last row in the copytorow +1,
                    'so mycol would go from being column J to column Q
                    mycol = .Range("IV" & copytorow).End(xlToLeft).Column + 1
                        
                        'set the variable range to rows that you are copying over so later you can delete them
                        If rng Is Nothing Then  'if rng is not set then
                            Set rng = .Rows(c.Row & ":" & c.Row)    'set rng equal to the current cell in the loop's row
                       
                        Else: Set rng = Union(rng, .Rows(c.Row & ":" & c.Row))  'if it is set add another row to the range
                        
                        End If
                    
        Else    'if the current cell in the loop is not equal to the variable Aname then
            mycol = 10  'reset mycol to 10 (column J)
            copytorow = c.Row   'reset myrow (to the current cell in the loops row)
            AName = c.Value 'reset Aname to the current cell in the loop's value
        End If
    
    Next c  'move to next cell in the loop

rng.Select  'select the cells whose row were added to rng
Selection.Delete shift:=xlUp    'delete the rows
End With

End Sub

6. Here, anything that appears in green is a comment meant to help you understand what the code it doing.
7. Close out of the Visual Basic Window
8. Press Alt+F8 on your keyboard
9. This time select the UniqueValues macro and then select run.

Let me know if this works for you, I understand if you still do not wish to use VBA.

Thanks!

[Marcol]

See if this workbook helps, or at least gives you a start, I haven't fully checked it, you might get 0 returned if the original cell is blank.

[Fotis1991]

@ rvasquez

Thank you, FOR YOUR TIME AND YOUR EFFORD.! Your code and your instuctions are very good and i promise to study these! Good opportunity to start learning VBA!

@ Marcol.

I did not thought to use dates in row 2. Everything works Ok.Ilet you know if a have some other problem on this!

Thank you!