Eu fiquei sem tempo, então não estou prometendo que seja eficiente ou mesmo codificado, mas esse VBa funciona. (editar, e também não percebeu que você tinha uma resposta aceita, mas vai manter isso de qualquer maneira)
Não há opção de desfazer ao executar o VBa, então faça o backup primeiro.
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
Antes
Depois
Comovocêpodever,vocênãoprecisacriarasegundatabela,elatambéméfeitaautomaticamente
Como eu adiciono o VBA no MS Office?