У меня закончилось время, поэтому я не обещаю, что это эффективно или даже хорошо написано, но этот VBa работает. (отредактируйте, а также не поняли, что у вас есть принятый ответ, но сохраните его в любом случае)
При запуске VBa опция отмены отсутствует, поэтому сначала выполните резервное копирование.
Option Explicit Sub doTheThing() Dim userStartRowInColA As Integer userStartRowInColA = 2 'update this as needed, in your example I assume the rows start on row 2 Dim userColDifference As Integer userColDifference = 2 'in your example, the top table is every 2 rows, hence the 2 Dim startRowInColA As Integer startRowInColA = userStartRowInColA Dim vals As String vals = "" Dim items As String items = "" Dim valsMissedTwo As Boolean valsMissedTwo = False Dim startCol As Integer startCol = 65 Do While (True) Dim col As String col = Chr(startCol) If Range(col & 1).Value = "" And valsMissedTwo Then Exit Do Else valsMissedTwo = False End If If Range(col & 1).Value = "" And Not valsMissedTwo Then valsMissedTwo = True End If If Range(col & 1).Value <> "" Then vals = vals + Range(col & 1).Value + "," End If startCol = startCol + 1 Loop Do While Range("A" & startRowInColA).Value <> "" items = items + Range("A" & startRowInColA).Value + "," startRowInColA = startRowInColA + 1 Loop Dim table2StartCol As Integer Dim table2StartRow As Integer table2StartRow = startRowInColA + 1 table2StartCol = 66 Dim splitVals() As String splitVals = Split(vals, ",") Dim splitItems() As String splitItems = Split(items, ",") 'add the items as cols For startCol = 1 To UBound(splitItems) If splitItems(startCol - 1) <> "" Then Range(Chr(65 + startCol) & startRowInColA + 5).Value = splitItems(startCol - 1) End If Next startCol 'add the vals on left as rows For startCol = 1 To UBound(splitVals) If splitVals(startCol - 1) <> "" Then Range("A" & startCol + startRowInColA + 5).Value = splitVals(startCol - 1) End If Next startCol 'now to populate Dim sr As Integer sr = startRowInColA + 6 Dim sc As Integer sc = 66 Dim oSr As Integer oSr = userStartRowInColA Dim i As Integer i = 0 Dim j As Integer j = 0 Do While (True) Do While Range(Chr(sc) & oSr).Value <> "" Range(Chr(sc + i) & sr).Value = Range(Chr(sc + j) & oSr).Value i = i + 1 oSr = oSr + 1 Loop j = j + userColDifference i = 0 oSr = userStartRowInColA sr = sr + 1 If Range("A" & sr).Value = "" Then Exit Do End If Loop End Sub
До
После
Как видите, вам не нужно создавать вторую таблицу, это также делается автоматически
Как добавить VBA в MS Office?