VBA unable to process huge dataset. How can i optimize it?

Question

The code below works perfectly for a dataset that is small however it falls over with datasets that have rows that exceed 50,000 as well as when there are blanks. The dataset looks as follows;

Col1     Col2    Col3       Col4
ServerA  1002    CPU        1
ServerA  1003    Cores      
ServerA  1005    Memory     16
ServerB  1010    CPU        8
ServerB  1050    Cores      
ServerC  5050    Network1   192.168.0.1
ServerC  2015    Network2   
ServerC  9401    Status     Active
ServerC  9401    Activity   Web

Code

Option Explicit

Sub Sample()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim RngToUnstack As Range, cel As Range, cel1 As Range
Dim i As Long

Set ws1 = ThisWorkbook.Sheets("Sheet2")
Set ws2 = ThisWorkbook.Sheets("Sheet3")

Set RngToUnstack = ws1.UsedRange
'~~> just an alternative to .UsedRange
'Set RngToUnstack = ws1.Range("A1", "D" & ws1.Range("A" & _
    ws1.Rows.Count).End(xlUp).Row)

'~~> construct your unique ID's in Worksheet 2
With ws2
    RngToUnstack.Resize(, 1).Copy .Range("A1")
    .Range("A1", .Range("A" & .Rows.Count).End(xlUp).Address).RemoveDuplicates 1, xlNo
End With
'~~> loop to populate the ID's
For Each cel1 In ws2.Range("A1", ws2.Range("A" & ws2.Rows.Count).End(xlUp).Address)
    i = 0
    For Each cel In RngToUnstack.Resize(, 1)
        If cel.Value = cel1.Value Then
            cel.Resize(, 3).Offset(0, 1).Copy cel1.Offset(0, (3 * i) + 1)
            i = i + 1
        End If
    Next cel
Next cel1
End Sub

Answer 1

Instead of doing a nested loop, sort the first sheet to group the data and loop over the rows, incrementing the columns to paste to as you go. If you need to retain the original order add a column and set the values equal to the row numbers and include that as your secondary sort key.

Sub Sample()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim RngToUnstack As Range
Dim RowSource As Long
Dim RowDest As Long
Dim ID As String
Dim Count As Long

Set ws1 = ThisWorkbook.Sheets("Sheet2")
Set ws2 = ThisWorkbook.Sheets("Sheet3")

Set RngToUnstack = ws1.UsedRange

RngToUnstack.Sort Key1:=RngToUnstack.Columns(1)

RowDest = 0

For RowSource = 1 To RngToUnstack.Rows.Count
    If ID <> RngToUnstack.Cells(RowSource, 1) Then
        ID = RngToUnstack.Cells(RowSource, 1)
        RowDest = RowDest + 1
        Count = -1
        ws2.Cells(RowDest, 1) = ID
    End If
    Count = Count + 1
    ws2.Cells(RowDest, Count * 3 + 2) = RngToUnstack.Cells(RowSource, 2)
    ws2.Cells(RowDest, Count * 3 + 3) = RngToUnstack.Cells(RowSource, 3)
    ws2.Cells(RowDest, Count * 3 + 4) = RngToUnstack.Cells(RowSource, 4)
Next RowSource

End Sub