Цитирование по динамическим столбцам и строкам и транспонирование данных

Question

У меня есть набор данных, который является динамическим, что означает N количество строк и N количество столбцов (групп). Первый снимок экрана - это то, как данные выглядят с тремя группами, но, как я сказал, это может быть N количество групп. Также может быть N количество элементов.

Исходные данные:

Второй скриншот показывает, как данные должны выглядеть. Мне нужно написать имя элемента для каждого балла (числовое значение в этой строке). Поэтому мне нужно каким-то образом переставить данные. Мне нужно пройти через столбцы, но не знаю, как разделить группы в цикле, поскольку они имеют одинаковые заголовки столбцов. Только определение и номер группы всегда уникальны.

Это должно быть сделано в VBA.

Окончательные данные после того, как цикл по строкам и столбцам и «транспонировать»:

Благодаря

EDIT: Вот код, который я пытался до сих пор, что оставляет пробелы между устанавливает и работает только для первой группы.

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

я воспользовался возможностью в Excel транспозиции, чтобы получить этот код, чтобы работать на основе данных выборочных точно так, как это показано на рисунке:

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

Взгляните на этот макрос и посмотреть, что вы думаете о Это. Я скопировал ваш набор образцов и смог дублировать ваши желаемые результаты с помощью вложенных циклов. Дайте мне знать, если что-то нуждается в разъяснении.

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