VBA to transpose data (excluding blanks) in rows based on a set of values

[Gloria1111]

Hi guys,

I have a spreadsheet with around 2000 rows of data and i need to transpose each row of data every n row, only that "n" is not fixed, and also to exclude the blanks.

I found a similar thread but it is only based on a fixed n row: VBA Transpose every nth row

How can i get it to transpose the row of data for Jan-June and skip the next "N" number of rows based on the indicated "N" value?

Example:

Original data

Name	Jan	Feb	Mar	Apr	May	June	N Value
John	123	24		22			2
John
John
Grace	23				67		1
Grace
Jason	400	646	23232	222	443	65	5
Jason
Jason
Jason
Jason
Jason

Desired result:

Name	Jan
John	123
John	24
John	22
Grace	23
Grace	67
Jason	400
Jason	646
Jason	23232
Jason	222
Jason	443
Jason	65

Any help/advice is greatly appreciated.
If my question is not clear, please let me know and i will see how i can rephrase or post a clearer example.

Thank you.

 

[mumps]

Does the "N" value always correspond to the number of blank rows for each name?

 

[Gloria1111]

Yes.
I managed to add in the number of blank rows according to the number of data for each person but now facing difficulty in transposing them without doing it manually.

 

[mumps]

Start by deleting the "N" values in column H as they are not needed and then try this macro. It will place the result in "Sheet2". Change the sheet names (in red) to suit you needs.

Sub TransposeData()
    Application.ScreenUpdating = False
    Dim x As Variant, srcWS As Worksheet, desWS As Worksheet, v As Variant, dic As Object, r As Long, c As Long, y As Long
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    v = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 7).Value
    ReDim x(1 To UBound(v), 1 To 1)
    Set dic = CreateObject("Scripting.Dictionary")
    For r = LBound(v) To UBound(v)
        If Not dic.Exists(v(r, 1)) Then
            dic.Add v(r, 1), Nothing
            For c = 2 To UBound(v, 2)
                If v(r, c) <> "" Then
                    y = y + 1
                    x(y, 1) = v(r, c)
                End If
            Next c
            With desWS
                If y > 0 Then
                    .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(y) = v(r, 1)
                    .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Resize(y) = x
                End If
            End With
        End If
    dic.RemoveAll
    y = 0
    Next r
    Application.ScreenUpdating = True
End Sub

The macro assumes that your actual data is organized in exactly the same way as the data you posted.

 

[Gloria1111]

Thank you so much!

 

[mumps]

You are very welcome.