Excel macro (VBA) para transpor várias colunas para várias linhas

Esse tipo de transformação é o que eu estava tentando realizar. Apenas para ilustração eu fiz isso como tabela. Então, basicamente, as 3 primeiras colunas devem repetir quantas colors já estão disponíveis. insira a descrição da imagem aqui

Procurei por outros tipos semelhantes, mas não consegui encontrar quando quero que várias colunas sejam repetidas. Eu encontrei este código on-line, mas é Nome Obrigado Localização Agradecer Localização Obrigado Localização Agradecer Localização e faz com que seja abaixo Nome Obrigado Localização

Sub createData() Dim dSht As Worksheet Dim sSht As Worksheet Dim colCount As Long Dim endRow As Long Dim endRow2 As Long Set dSht = Sheets("Sheet1") 'Where the data sits Set sSht = Sheets("Sheet2") 'Where the transposed data goes sSht.Range("A2:C60000").ClearContents colCount = dSht.Range("A1").End(xlToRight).Column '// loops through all the columns extracting data where "Thank" isn't blank For i = 2 To colCount Step 2 endRow = dSht.Cells(1, i).End(xlDown).Row For j = 2 To endRow If dSht.Cells(j, i)  "" Then endRow2 = sSht.Range("A50000").End(xlUp).Row + 1 sSht.Range("A" & endRow2) = dSht.Range("A" & j) sSht.Range("B" & endRow2) = dSht.Cells(j, i) sSht.Range("C" & endRow2) = dSht.Cells(j, i).Offset(0, 1) End If Next j Next i End Sub 

Poderia alguém ajudar a mudar o formato que eu queria, eu tentei mudar o passo 2 para 1 ej para começar a partir de 4, mas isso não foi útil Outro exemplo com 2 conjuntos variados: 2 conjuntos variados

insira a descrição da imagem aqui

Aqui está uma abordagem genérica “unpivot” (todas as colunas “fixas” devem aparecer à esquerda dos dados de input)

Teste sub:

 Sub Tester() Dim p 'get the unpivoted data as a 2-D array p = UnPivotData(Sheets("Sheet1").Range("A1").CurrentRegion, _ 3, False, False) With Sheets("Sheet1").Range("H1") .CurrentRegion.ClearContents .Resize(UBound(p, 1), UBound(p, 2)).Value = p 'populate array to sheet End With 'EDIT: alternative (slower) method to populate the sheet ' from the pivoted dataset. Might need to use this ' if you have a large amount of data Dim r As Long, c As Long For r = 1 To Ubound(p, 1) For c = 1 To Ubound(p, 2) Sheets("Sheet2").Cells(r, c).Value = p(r, c) Next c Next r End Sub 

Função UnPivot:

 Function UnPivotData(rngSrc As Range, fixedCols As Long, _ Optional AddCategoryColumn As Boolean = True, _ Optional IncludeBlanks As Boolean = True) Dim nR As Long, nC As Long, data, dOut() Dim r As Long, c As Long, rOut As Long, cOut As Long, cat As Long Dim outRows As Long, outCols As Long data = rngSrc.Value 'get the whole table as a 2-D array nR = UBound(data, 1) 'how many rows nC = UBound(data, 2) 'how many cols 'calculate the size of the final unpivoted table outRows = nR * (nC - fixedCols) outCols = fixedCols + IIf(AddCategoryColumn, 2, 1) 'resize the output array ReDim dOut(1 To outRows, 1 To outCols) 'populate the header row For c = 1 To fixedCols dOut(1, c) = data(1, c) Next c If AddCategoryColumn Then dOut(1, fixedCols + 1) = "Category" dOut(1, fixedCols + 2) = "Value" Else dOut(1, fixedCols + 1) = "Value" End If 'populate the data rOut = 1 For r = 2 To nR For cat = fixedCols + 1 To nC If IncludeBlanks Or Len(data(r, cat)) > 0 Then rOut = rOut + 1 'Fixed columns... For c = 1 To fixedCols dOut(rOut, c) = data(r, c) Next c 'populate unpivoted values If AddCategoryColumn Then dOut(rOut, fixedCols + 1) = data(1, cat) dOut(rOut, fixedCols + 2) = data(r, cat) Else dOut(rOut, fixedCols + 1) = data(r, cat) End If End If Next cat Next r UnPivotData = dOut End Function 

Aqui está uma maneira ( mais rápida? ) Usando matrizes. Esta abordagem é melhor que a questão ligada, uma vez que não lê e escreve para / de objects de intervalo em um loop. Eu comentei o código para que você não tenha problemas em entendê-lo.

 Option Explicit Sub Sample() Dim wsThis As Worksheet, wsThat As Worksheet Dim ThisAr As Variant, ThatAr As Variant Dim Lrow As Long, Col As Long Dim i As Long, k As Long Set wsThis = Sheet1: Set wsThat = Sheet2 With wsThis '~~> Find Last Row in Col A Lrow = .Range("A" & .Rows.Count).End(xlUp).Row '~~> Find total value in D,E,F so that we can define output array Col = Application.WorksheetFunction.CountA(.Range("D2:F" & Lrow)) '~~> Store the values from the range in an array ThisAr = .Range("A2:F" & Lrow).Value '~~> Define your new array ReDim ThatAr(1 To Col, 1 To 4) '~~> Loop through the array and store values in new array For i = LBound(ThisAr) To UBound(ThisAr) k = k + 1 ThatAr(k, 1) = ThisAr(i, 1) ThatAr(k, 2) = ThisAr(i, 2) ThatAr(k, 3) = ThisAr(i, 3) '~~> Check for Color 1 If ThisAr(i, 4) <> "" Then ThatAr(k, 4) = ThisAr(i, 4) '~~> Check for Color 2 If ThisAr(i, 5) <> "" Then k = k + 1 ThatAr(k, 1) = ThisAr(i, 1) ThatAr(k, 2) = ThisAr(i, 2) ThatAr(k, 3) = ThisAr(i, 3) ThatAr(k, 4) = ThisAr(i, 5) End If '~~> Check for Color 3 If ThisAr(i, 6) <> "" Then k = k + 1 ThatAr(k, 1) = ThisAr(i, 1) ThatAr(k, 2) = ThisAr(i, 2) ThatAr(k, 3) = ThisAr(i, 3) ThatAr(k, 4) = ThisAr(i, 6) End If Next i End With '~~> Create headers in Sheet2 Sheet2.Range("A1:D1").Value = Sheet1.Range("A1:D1").Value '~~> Output the array wsThat.Range("A2").Resize(Col, 4).Value = ThatAr End Sub 

SHEET1

insira a descrição da imagem aqui

SHEET2

insira a descrição da imagem aqui