Таблица переноса Excel VBA

Question

Я пытаюсь переставить таблицу выше (синего цвета) в таблицу внизу.

Может кто-нибудь помочь?Использование метода Excel VBA для транспонирования этих данных.

Ценится.Спасибо

Answer 1

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

Если вы не знаете, как что-то сделать в VBA, запишите макрос в Excel, а затем посмотрите на код того, как это делается.Транспонирование матрицы - это то, что может сделать только Excel, поэтому вы можете записать, как Excel выполняет действие, а затем посмотреть на код.

Это не даст вам лучший код, но поможет вам понять, каксделать это:)

Answer 2

Это сработает, но не передаст форматы (поскольку это действительно утомительно, и я хотел избежать копирования ячеек)

Также посмотрите .PasteSpecial Paste:=xlPasteFormats здесь

Копирование выполняется довольно медленно и (софт) блокирует вашу рабочую станцию ​​во время ее работы - вы не можете использовать копирование и вставку во время копирования.

Sub TransposeTable()

' You can also select a sheet like ThisWorkbook.Sheets("MySheet")
Set SourceWorkbook = ThisWorkbook.Sheets(1)
' You can select sheets from other open Workbooks by Application.Workbooks(1) or Application.Workbooks("MyWorkbook.xlsx") instead of ThisWorkbook
Set TargetWorkbook = ThisWorkbook.Sheets(2)

' Check the size of the source table
LastRowSource = SourceWorkbook.Cells(Rows.Count, 1).End(xlUp).Row
LastColumnSource = SourceWorkbook.Cells(1, Columns.Count).End(xlToLeft).Column

' Add more headers below
Headers = Array("Question", "Points", "Some other header", "Yet another header")
HeaderCount = UBound(Headers) + 1 ' Array indices start at 0, Cell columns and rows start at 1

Range(TargetWorkbook.Cells(1, 1), TargetWorkbook.Cells(1, HeaderCount)) = Headers ' Print headers

' Loop all columns in the first row of source table
For Each SourceColumn In Range(SourceWorkbook.Cells(1, 1), SourceWorkbook.Cells(1, LastColumnSource))
    ' Loop all rows in the first column of the source table
    For Each SourceRow In Range(SourceWorkbook.Cells(1, 1), SourceWorkbook.Cells(LastRowSource, SourceColumn.Column))
        ' Swap row and column in target and assign value to target
        TargetWorkbook.Cells(SourceColumn.Column + 1, SourceRow.Row).Value = SourceWorkbook.Cells(SourceRow.Row, SourceColumn.Column).Value
    Next SourceRow
Next SourceColumn

End Sub

РЕДАКТИРОВАТЬ: Добавление обновленного решения на основеКомментарии ОП.

' Set this to true if you want to delete TargetWorkbook cells before each run
Const DELETE_TARGET_CELLS = False

Sub TransposeTable()

' You can also select a sheet like ThisWorkbook.Sheets("MySheet")
Set SourceWorkbook = ThisWorkbook.Sheets(1)
' You can select sheets from other open Workbooks by Application.Workbooks(1) or Application.Workbooks("MyWorkbook.xlsx")
Set TargetWorkbook = ThisWorkbook.Sheets(2)

If DELETE_TARGET_CELLS Then TargetWorkbook.Cells.Delete

' Check the size of the source table
LastRowSource = SourceWorkbook.Cells(Rows.Count, 1).End(xlUp).Row
LastColumnSource = SourceWorkbook.Cells(1, Columns.Count).End(xlToLeft).Column

' Add more headers below
Headers = Array("Question", "Points")
HeaderCount = UBound(Headers) + 1 ' Array indices start at 0, Cell columns and rows start at 1
Range(TargetWorkbook.Cells(1, 1), TargetWorkbook.Cells(1, HeaderCount)) = Headers ' Print headers

' We need to also track last row of Target worksheet
LastRowTarget = TargetWorkbook.Cells(Rows.Count, 1).End(xlUp).Row

'Loop first column of all rows of source table, skip first row since we don't want to duplicate headers
For Each SourceRow In Range(SourceWorkbook.Cells(2, 1), SourceWorkbook.Cells(LastRowSource, 1))
    ' Loop all columns of the first row of source table
    For Each SourceColumn In Range(SourceWorkbook.Cells(1, 1), SourceWorkbook.Cells(2, LastColumnSource))
        ' Copy headers to first column of target table
        TargetWorkbook.Cells(LastRowTarget + 1, 1).Value = SourceWorkbook.Cells(1, SourceColumn.Column).Value
        ' Copy values of the source row to the second column of target table
        TargetWorkbook.Cells(LastRowTarget + 1, 2).Value = SourceWorkbook.Cells(SourceRow.Row, SourceColumn.Column).Value
        ' Update last row number of target table so we don't overwrite finished target rows
        LastRowTarget = TargetWorkbook.Cells(Rows.Count, 1).End(xlUp).Row
    Next SourceColumn
Next SourceRow

End Sub