VBA Code for transpose for Large Data Set

[suresh ullanki]

Dear All,

Can you please help me to transpose data. I have three columns "Emp_ID, Compensation Plan and Amount. I want Compensation Plan to be transposed to Basic salary, HRA, Bonus and Commuting Allowance by Columns. I have 4000 employees list which has more than 18k rows. Please help

EMP_ID	Compensation Plan	Amount
152	Basic Salary	10
152	HRA	8
152	Bonus	5
152	Commuting Allowance	2
153	Basic Salary	20
153	HRA	18
153	Bonus	3
153	Commuting Allowance	2

<tbody>
</tbody>

 

[strooman]

I know you ask VBA solution but that is not my specialty. Therefore a formula mapproach to get you going and to clarify.
First, is this the layout of your dataset?
EMP_ID in Column A, Compensation Plan in Column B, Amount in Column C ?


Excel 2016 Professional (Windows) 64 bit

	A​	B​	C​	D​	E​	F​	G​	H​	I​
1​	EMP_ID	Compensation Plan	Amount		EMP_ID	Basic Salary	HRA	Bonus	Commuting Allowance
2​	154​	Basic Salary	€ 30,00​		154​	€ 30,00​	€ 33,25​	€ 13,00​
3​	157​	HRA	€ 40,00​		157​	€ 40,00​	€ 22,00​	€ 38,00​	€ 17,45​
4​	152​	Bonus	€ 31,00​		152​	€ 31,00​	€ 9,00​	€ 17,00​	€ 7,75​
5​	159​	Commuting Allowance	€ 38,00​		159​	€ 38,00​	€ 6,00​
6​	159​	Basic Salary	€ 6,00​		160​	€ 23,25​	€ 18,00​	€ 9,65​	€ 15,00​
7​	160​	HRA	€ 23,25​		153​	€ 17,45​	€ 24,00​	€ 34,00​	€ 25,00​
8​	153​	Bonus	€ 17,45​		155​	€ 81,00​	€ 32,00​	€ 12,00​	€ 81,00​
9​	155​	Commuting Allowance	€ 81,00​		156​	€ 7,00​	€ 30,00​	€ 31,00​	€ 6,00​
10​	152​	Basic Salary	€ 9,00​		158​	€ 23,25​
11​	155​	HRA	€ 32,00​
12​	160​	Bonus	€ 18,00​
13​	160​	Commuting Allowance	€ 9,65​
14​	155​	Basic Salary	€ 12,00​
15​	156​	HRA	€ 7,00​
16​	153​	Bonus	€ 24,00​
17​	153​	Commuting Allowance	€ 34,00​
18​	154​	Basic Salary	€ 33,25​
19​	152​	HRA	€ 17,00​
20​	160​	Bonus	€ 15,00​
21​	152​	Commuting Allowance	€ 7,75​
22​	154​	Basic Salary	€ 13,00​
23​	160​	HRA	€ 19,00​
24​	160​	Bonus	€ 10,00​
25​	157​	Commuting Allowance	€ 22,00​
26​	153​	Basic Salary	€ 25,00​
27​	156​	HRA	€ 30,00​
28​	152​	Bonus	€ 40,00​
29​	156​	Commuting Allowance	€ 31,00​
30​	157​	Basic Salary	€ 38,00​
31​	156​	HRA	€ 6,00​
32​	158​	Bonus	€ 23,25​
33​	157​	Commuting Allowance	€ 17,45​
34​	155​	Basic Salary	€ 81,00​
35​	155​	HRA	€ 9,00​
36​	157​	Bonus	€ 32,00​

Sheet: Sheet1

Formula's:
E2 =IFERROR(INDEX($A$2:$A$1000; MATCH(0;COUNTIF($E$1:E1; $A$2:$A$1000);0));””)
Insert with Control+Shift+Enter (Not just Enter) and drag down.

F2 =IFERROR(INDEX($C$2:$C$1000;SMALL(IF($A$2:$A$1000=$E2;ROW(A$2:A$1000)-ROW(A$2)+1);COLUMNS($F$2:F2)));"")
Insert with Control+Shift+Enter (Not just Enter) and drag from left to right and down.

For 18k rows you will indeed better of with a VBA solution.

 

[strooman]

I'm sorry . . . wrong formula in F2. Please replace with:

F2 =SUMPRODUCT((($A$2:$A$1000=$E2)*($B$2:$B$1000=F$1));$C$2:$C$1000)

Insert with Enter and drag from left to right and down.

 

[JoeMo]

Here's a VBA solution. Assumes data are in Columns A:C, with EMP_ID header in A1, and produces an output in Cols E:I starting in E1.

Sub suresh()
'assumes data starts with header EMP_ID in cell A1 and is sorted by EMP_ID
Dim R As Range, Vin As Variant, Hdrs As Variant, Vid As Variant, ct As Long, Vout As Variant
Dim i As Long, j As Long
Set R = Range("A1:C" & Cells(Rows.Count, "A").End(xlUp).Row)
Vin = R.Offset(1, 0).Resize(R.Rows.Count - 1, R.Columns.Count).Value
Application.ScreenUpdating = False
Range("E:J").ClearContents
With R.Columns(1)
    .AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("E1"), unique:=True
End With
Hdrs = Array("Basic Salary", "HRA", "Bonus", "Commuting Allowance")
Vid = Range("E2:E" & Cells(Rows.Count, "E").End(xlUp).Row).Value
Range("F1:I1").Value = Hdrs
ReDim Vout(1 To UBound(Vin, 1), 1 To 4)
For i = 1 To UBound(Vid, 1)
    For j = 1 To UBound(Vin, 1)
        If Vid(i, 1) = Vin(j, 1) Then
            ct = ct + 1
            Vout(i, ct) = Vin(j, 3)
            If ct = 4 Then
                ct = 0
                Exit For
            End If
        End If
    Next j
Next i
With Range("F2:I" & 1 + UBound(Vid, 1))
    .Value = Vout
    .EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
End Sub