excel macro (VBA) per trasporre più colonne su più righe

Questo tipo di trasformazione è ciò che stavo cercando di eseguire. Solo per l’illustrazione l’ho fatto come tabella. Fondamentalmente, la prima colonna 3 dovrebbe essere ripetuta per quanti colors sono disponibili. inserisci la descrizione dell'immagine qui

Ho cercato altri tipi simili ma non ho trovato quando voglio ripetere più colonne. Ho trovato questo codice online ma è il nome Grazie a Location Grazie a Location Grazie a Location Location e lo rende come sotto Name Thank Location

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 

Qualcuno potrebbe aiutare a cambiare il formato che voglio, ho provato a cambiare il passo 2 a 1 e j a partire da 4, ma ciò non è stato utile Un altro esempio con 2 serie diverse: 2 set diversi

inserisci la descrizione dell'immagine qui

Ecco un approccio generico “unpivot” (tutte le colonne “fisse” devono apparire a sinistra dei dati di input)

Prova 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 

Funzione 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 

Ecco un modo ( più veloce? ) Usando gli array. Questo approccio è migliore della domanda collegata poiché non legge e scrive da / per gli oggetti intervallo in un ciclo. Ho commentato il codice quindi non dovresti avere problemi a capirlo.

 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

inserisci la descrizione dell'immagine qui

sheet2

inserisci la descrizione dell'immagine qui