I have a example table with 3 columns (Sample, Index, Value). In this example, there are 12 samples, 3 possible Index and for each of them a Value. I would like to transpose to columns the Value by Index Notes: For each sample, the number of Index measured (with Value) may be different. The number of Samples & Index may also change for a different dataset.
Please find Image of the original table and the desired transposed table (sorry if my description is inaccurate). Kindly help a VBA code for such a purpose. Thank you.
I could only do a VBA transpose if each set of rows is of the same size (fixed step size).
I have a example table with 3 columns (Sample, Index, Value). In this example, there are 12 samples, 3 possible Index and for each of them a Value. I would like to transpose to columns the Value by Index Notes: For each sample, the number of Index measured (with Value) may be different. The number of Samples & Index may also change for a different dataset.
Please find Image of the original table and the desired transposed table (sorry if my description is inaccurate). Kindly help a VBA code for such a purpose. Thank you.
I could only do a VBA transpose if each set of rows is of the same size (fixed step size).
Just the pivot table:
Should be fast on bulky data.
PowerQuery offers a more efficient solution than using a VBA script to transform your table.
let
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
#"Changed Type" = Table.TransformColumnTypes(Source,{{"Sample", type text}, {"Index", type text}, {"Value", type number}}),
#"Pivoted Column" = Table.Pivot(#"Changed Type", List.Distinct(#"Changed Type"[Index]), "Index", "Value", List.Sum)
in
#"Pivoted Column"
If you prefer to use a VBA script instead
Option Explicit
Sub Demo()
Dim oDic1 As Object, oDic2 As Object, rngData As Range
Dim i As Long, j As Long, sKey As String
Dim arrData, arrTemp()
Set oDic1 = CreateObject("scripting.dictionary")
Set oDic2 = CreateObject("scripting.dictionary")
Set rngData = Sheets("Source").Range("A1").CurrentRegion ' change sheet name as needed
' load table into an array
arrData = rngData.Value
For i = LBound(arrData) + 1 To UBound(arrData)
sKey = arrData(i, 1)
If Not oDic1.exists(sKey) Then ' get unique list of Sample
oDic1(sKey) = ""
End If
sKey = arrData(i, 2)
If Not oDic2.exists(sKey) Then ' get unique list of IndexN
oDic2(sKey) = oDic2.Count + 1
End If
Next i
Dim iCol As Long: iCol = oDic2.Count
oDic1.RemoveAll
Dim iColIdx As Long
For i = LBound(arrData) + 1 To UBound(arrData)
sKey = arrData(i, 1)
If Not oDic1.exists(sKey) Then ' init. array for each sample
ReDim arrTemp(iCol)
arrTemp(0) = arrData(i, 1)
oDic1(sKey) = arrTemp
Else
arrTemp = oDic1(sKey)
End If
iColIdx = oDic2(arrData(i, 2))
arrTemp(iColIdx) = arrTemp(iColIdx) + arrData(i, 3) ' get sum
oDic1(sKey) = arrTemp
Next i
Sheets.Add ' creat new sheet for ouput
' populate header row
Range("A1") = "Sample"
Range("B1").Resize(1, iCol).Value = Application.Transpose(oDic2.keys)
' write output to sheet
Range("A2").Resize(oDic1.Count, iCol + 1).Value = Application.Transpose(Application.Transpose(oDic1.items()))
Set oDic1 = Nothing
End Sub
Microsoft documentation:
Range.Resize property (Excel)
Range.CurrentRegion property (Excel)
Dictionary object
Excel formulas (provided by @Mayukh Bhattacharya)
=PIVOTBY(A2:A29,B2:B29,C2:C29,SINGLE,,0,,0)
Option Explicit
Sub Demo()
Dim oDic1 As Object, oDic2 As Object, rngData As Range
Dim I As Long, j As Long, sKey As String
Dim arrData, arrTemp()
Dim cdLR As Long
Set oDic1 = CreateObject("scripting.dictionary")
Set oDic2 = CreateObject("scripting.dictionary")
Set rngData = Sheets("Source").Range("A1").CurrentRegion ' change sheet name as needed
' load table into an array
arrData = rngData.Value
For I = LBound(arrData) + 1 To UBound(arrData)
sKey = arrData(I, 1)
If Not oDic1.exists(sKey) Then ' get unique list of Sample
oDic1(sKey) = ""
End If
sKey = arrData(I, 2)
If Not oDic2.exists(sKey) Then ' get unique list of IndexN
oDic2(sKey) = oDic2.Count + 1
End If
Next I
Dim iCol As Long: iCol = oDic2.Count
oDic1.RemoveAll
Dim iColIdx As Long
For I = LBound(arrData) + 1 To UBound(arrData)
sKey = arrData(I, 1)
If Not oDic1.exists(sKey) Then ' init. array for each sample
ReDim arrTemp(iCol)
arrTemp(0) = arrData(I, 1)
oDic1(sKey) = arrTemp
Else
arrTemp = oDic1(sKey)
End If
iColIdx = oDic2(arrData(I, 2))
Cells(I, 5).Value = Cells(I, 2) ' Copy Index into a temp column
arrTemp(iColIdx) = arrTemp(iColIdx) + arrData(I, 3) ' get sum
oDic1(sKey) = arrTemp
Next I
' Remove duplicate Index
cdLR = Sheets("Source").Cells(Rows.Count, "E").End(xlUp).Row
Sheets("Source").Range("E1:J" & cdLR).RemoveDuplicates Columns:=1
' Copy and paste transpose Index rows to Header columns
cdLR = Sheets("Source").Cells(Rows.Count, "E").End(xlUp).Row
Sheets("Source").Range("E2:E" & cdLR).Copy
Sheets("New").Cells(1, 2).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Sheets("Source").Range("E:E").Clear
' populate header row
Sheets("New").Range("A1") = "Sample"
' Remove this line which populates only single Index header
' Sheets("New").Range("B1").Resize(1, iCol).Value = Application.Transpose(oDic2.keys)
' write output to sheet
Sheets("New").Range("A2").Resize(oDic1.Count, iCol + 1).Value = Application.Transpose(Application.Transpose(oDic1.items()))
Set oDic1 = Nothing
End Sub