Как использовать VBA для преобразования из вертикальных данных в горизонтальные данные?

Question

Я перенес свои данные с одного листа на другой через VBA.Я хочу использовать таблицу для визуализации данных.Но он может только читать данные, если он горизонтальный.Мне нужен год, чтобы зациклить его, а затем вставить данные рядом с ним, как показано на рисунке ниже.Я добавил код, который я использую для перемещения данных, в последней части, если это необходимо.Мне нужно сделать это возможным с помощью VBA, а не с помощью функции транспонирования.

Рисунок является примером того, как я хотел бы, чтобы он выглядел .. "результат, который я ищу"

РЕДАКТИРОВАНИЕ ДОБАВЛЕНО:

    Sub MyProcedure()
a = Worksheets("ark1").Cells(Rows.Count, 1).End(xlUp).Row

MsgBox (a)

End Sub

Private Sub CommandButton1_Click()
Dim nøgletal As String, år As Integer
    Worksheets("Ark2").Select
    nøgletal = Range("B2")
    år = Range("C2")
    Worksheets("Ark1").Select
    Worksheets("Ark1").Range("A4").Select
    ThisWorkbook.Worksheets("Ark1").Range("C1:C100").Value = ThisWorkbook.Worksheets("Ark2").Range("C12:C100").Value
    ThisWorkbook.Worksheets("Ark1").Range("D1:D100").Value = ThisWorkbook.Worksheets("Ark2").Range("D12:D100").Value
   ThisWorkbook.Worksheets("Ark1").Range("E1:E100").Value = ThisWorkbook.Worksheets("Ark2").Range("M12:M100").Value
   ThisWorkbook.Worksheets("Ark1").Range("F1:F100").Value = ThisWorkbook.Worksheets("Ark2").Range("N12:N100").Value
   ThisWorkbook.Worksheets("Ark1").Range("G1:G100").Value = ThisWorkbook.Worksheets("Ark2").Range("O12:O100").Value
   ThisWorkbook.Worksheets("Ark1").Range("A1:A16").Value = ThisWorkbook.Worksheets("Ark2").Range("A12:A16").Value
    If Worksheets("Ark1").Range("A4").Offset(1, 0) <> "" Then
    Worksheets("Ark1").Range("A4").End(xlDown).Select
    End If
    ActiveCell.Offset(1, 0).Select
    ActiveCell.Value = nøgletal
    ActiveCell.Offset(0, 1).Select
    ActiveCell.Value = år
    Worksheets("Ark2").Select
    Worksheets("Ark2").Range("B2", "B16").Select
End Sub

Answer 1

На основе вашего изображения с цветными ячейками и того, что вы ищете. Это то, что вы показываете

    Sub x()

Dim lngDataColumns As Long
Dim lngDataRows As Long

lngDataColumns = 3
lngDataRows = 4

For t = 1 To lngDataRows

Range("l2").Offset(((t - 1) * lngDataColumns) - 1, 0).Resize(lngDataColumns, 1).Value = _
        Application.Transpose(Range("e1:g1").Value)

Range("M2").Offset(((t - 1) * lngDataColumns) - 1, 0).Resize(lngDataColumns, 1).Value = _
        Application.Transpose(Range("e1:g1").Offset(t).Value)

Next t

End Sub

Answer 2

Я создал новую версию в VBA, которая будет делать то, что вы ожидаете.Поток, чтобы узнать, когда система прекращает поиск, основан на содержимом, поэтому, пока столбец слева для годового содержимого будет пустым, система продолжит поиск, но когда найдет значение (например, НАУКА), она прекратит поиск.Эта первая часть является примером того, как вы можете вызвать функцию, чтобы указать исходные и конечные листы, а также значения в целых числах, где можно найти ваш диапазон:

Private Sub TestingCall()
    Call SpecialTranspose("Ark2", "Ark1", 1, 5)
End Sub

Private Sub SpecialTranspose(strSRCSheet As String, strDSTSheet As String, lngRow As Long, lngCol As Long)
    Dim iRow, iCol As Long
    Dim dstRow, dstCol As Long

    dstRow = 1
    dstCol = 1

    iRow = lngRow + 1
    While Len(Sheets(strSRCSheet).Cells(iRow, lngCol - 1).Value) = 0
        iCol = lngCol
        While Len(Sheets(strSRCSheet).Cells(iRow, iCol).Value) > 0
            Debug.Print iRow, iCol
            Sheets(strDSTSheet).Cells(dstRow, dstCol).Value = Sheets(strSRCSheet).Cells(lngRow, iCol).Value
            Sheets(strDSTSheet).Cells(dstRow, dstCol + 1).Value = Sheets(strSRCSheet).Cells(iRow, iCol).Value
            dstRow = dstRow + 1
            iCol = iCol + 1
        Wend
        iRow = iRow + 1
    Wend
End Sub