Looping through dynamic columns and rows and transposing data - vba

Question

I have a dataset that is dynamic, meaning N number of rows and N number of columns (groups). The first screenshot is how the data looks with 3 groups, but as I said it could be N number of groups. There can also be N number of items.
Initial Data:
The second screenshot shows how the data should look. I need to write the item name for every score (numeric value in that row). So I have to transpose the data somehow. I need to loop through the columns, but don't know how divide the groups in the loop since they have the same column headers. Only the definition and group number are always unique.
This has to be done in VBA.
Final data after looping through rows and columns and "transposing":
Thanks
EDIT: Here's the code I've tried so far, which leaves spaces between the sets and only works for the first group.
Sub transposeData()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lastRow As Long
Dim i As Long
Dim lastCol As Long
Dim j As Long
Dim n As Integer
Dim y As Long
Dim tempVal As Integer
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = Workbooks("Workbook2").Worksheets("Sheet1")
lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
lastCol = ws.Cells(ws2.Rows.Count, 1).End(xlUp).Row
For i = 3 To lastRow Step 1
For y = 3 To lastRow Step 1
For j = 3 To lastCol Step 1
If ws.Cells(i, j) <> vbNullString Then
tempVal = ws.Cells(i, j).Value
ws2.Cells(y, 2) = ws.Cells(i, 2).Value
ws2.Cells(y, 3) = tempVal
ws2.Cells(y, "K") = ws.Cells(2, j).Value
End If
If tempVal <> 0 And tempVal - 1 Then
y = y + 1
End If
If j = 41 Then
i = i + 1
End If
tempVal = 0
y = y
Next j
Next y
Next i
End Sub

Answer 1

I took advantage of Excel's Transpose ability to get this code to work based on your sample data exactly as it is shown:
Sub Transpose()
Dim ws As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1") 'Sheets("Sheet1")
Set ws2 = Workbooks("Workbook2").Worksheets("Sheet1") 'Sheets("Sheet2")
ws2.Range("A1:D1").Value = Array("Name", "Value", "Test", "Defintion")
With ws1
'how many groups are there so we know how many times to transpose
'we find this out by counting the number of times "Defintion" appears
Dim lDef As Long
lDef = Application.WorksheetFunction.CountIf(.Rows(2), "Definition")
'get last row where grouped data appears
Dim lRow As Long
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Dim l As Long
For l = 3 To lRow 'loop through items
Dim rDef As Range, sFirst As String
Set rDef = .Rows(2).Find("Definition") 'find first instance of "Definition"
sFirst = rDef.Address 'get address of first occurence so we can test if we reached it again
'list Name (aka Item) (for as many rows as needed defined by how many groups * 4 (1 for each test))
With ws2
.Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(4 * lDef).Value = ws1.Range("A" & l)
End With
Do
'transpose values
rDef.Offset(l - 2, 1).Resize(1, 4).Copy 'uses l-2 to offset for each row throughout the loop
With ws2
'paste values (test results)
.Range("B" & .Rows.Count).End(xlUp).Offset(1).Resize(4, 1).PasteSpecial xlPasteValues, Transpose:=True
'load test cases
.Range("C" & .Rows.Count).End(xlUp).Offset(1).Resize(4, 1).Value = Application.WorksheetFunction.Transpose(Array("A", "B", "C", "D"))
'load definitions
.Range("D" & .Rows.Count).End(xlUp).Offset(1).Resize(4, 1).Value = Application.WorksheetFunction.Transpose(rDef.Offset(1).Value)
End With
Set rDef = .Rows(2).FindNext(After:=rDef) 'find next definition
Loop Until rDef Is Nothing Or rDef.Address = sFirst
Next
End With
End Sub

Answer 2

Take a look at this macro and see what you think about it. I copied your sample set and was able to duplicate your desired results using nested for loops. Let me know if anything needs clarification.
Option Explicit
Sub customTransposing()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim startingRow As Integer
Dim startingColumn As Integer
Dim numberOfPoints As Integer
Dim numberOfEntries As Integer
Dim numberOfGroups As Integer
Dim outputRowOffset As Integer
' -------------------------------------------------------------------------------------------
' User Variables
' -------------------------------------------------------------------------------------------
startingRow = 3
startingColumn = 1
numberOfPoints = 4 ' The number of test points i.e. A B C D
numberOfEntries = 0
numberOfGroups = 3
outputRowOffset = 10
' -------------------------------------------------------------------------------------------
' Counts the number of entries in the first column
' this section could most likely be improved
Cells(startingRow, startingColumn).Select
Do Until IsEmpty(ActiveCell)
If Not IsEmpty(ActiveCell) Then
numberOfEntries = numberOfEntries + 1
End If
ActiveCell.Offset(1, 0).Select
Loop
For j = 0 To numberOfEntries - 1
For k = 0 To numberOfGroups - 1
For i = 0 To numberOfPoints - 1
' first column
Cells(startingRow + numberOfEntries + (j * numberOfPoints * numberOfGroups) + outputRowOffset + i + k * numberOfPoints, startingColumn).Value = Cells(startingRow + j, startingColumn)
' second column
Cells(startingRow + numberOfEntries + (j * numberOfPoints * numberOfGroups) + outputRowOffset + i + k * numberOfPoints, startingColumn + 1).Value = Cells(startingRow + j, startingColumn + 2 + i + k * (numberOfGroups + 2))
' third column
Cells(startingRow + numberOfEntries + (j * numberOfPoints * numberOfGroups) + outputRowOffset + i + k * numberOfPoints, startingColumn + 2).Value = Cells(startingRow - 1, startingColumn + 2 + i)
' fourth column
Cells(startingRow + numberOfEntries + (j * numberOfPoints * numberOfGroups) + outputRowOffset + i + k * numberOfPoints, startingColumn + 3).Value = Cells(startingRow + j, startingColumn + 1 + k * (numberOfGroups + 2))
Next i
Next k
Next j
End Sub