Sub Katchap()
Dim result()
t = Timer
Set dict = CreateObject("scripting.dictionary")
dict.comparemode = vbTextCompare
'*********************************************************
'initial known elements in this specific order !!! (without unnecessary spaces)
'*********************************************************
sp = Split("Ag,Al,Al203,As,Au,Ba,Be,Bi,C_Tot,Ca,CaO,Cd,Ce,Co,Cr,Cs,Cu,Dy,Er,Eu,Fe,FeO,Ga,Gd,Hf,Hg,Ho,K,K2O,La,LOI,Lu,Mg,MgO,Mn,MnO,Mo,Na,Na2O,Nb,Nd,Ni,P205,P,Pass75um,Pb,Pd,Pr,Pt,Rb,S,S_Tot,Sb, Sc,Se,SiO2,Sm,Sn,Sr,Ta,Tb,Te,Th,Ti,TiO2,Tl,Tm,U,V,W,WO3,Wt,Y,Yb,Zn,Zr", ",")
For i = 0 To UBound(sp)
s = "element:" & sp(i) 'use "element:" and your element
If Not dict.exists(s) Then 'does that key exists already
i2 = i2 + 1 'index next element
dict.Add s, Array(i2, s) 'add to dictionary
End If
Next
With Sheets("blad1") 'your sheet
arr = .UsedRange.Value 'your data
ReDim result(1 To UBound(arr), 1 To 250) 'prepare an array (oversized for approx. 120 elements)
For i = 1 To UBound(arr)
If i Mod 100 = 0 Then Application.StatusBar = UBound(arr) & Space(5) & i 'follow the processing in the statusbar
s = Join(Application.Index(arr, i, Array(1, 2, 3, 4, 5)), "|") 'the first 5 columns joined
If Not dict.exists(s) Then 'look if this unique key exists already
i1 = i1 + 1 'index for next unique key
dict.Add s, Array(i1, s) 'add to dictionary
For j = 1 To 5: result(i1, j) = arr(i, j): Next 'write first 5 columns to array
End If
r = dict(s)(0) 'row to be used later
s = "element:" & arr(i, 6) 'use "element:" and your element
If Not dict.exists(s) Then 'does that key exists already
i2 = i2 + 1 'index next element
dict.Add s, Array(i2, s) 'add to dictionary
End If
k = dict(s)(0) * 2 + 4 'column to be used later
result(r, k) = arr(i, 7) 'fill the amount
result(r, k + 1) = arr(i, 8) 'fill the text
Next
t1 = Timer
Application.StatusBar = "writing to worksheet"
Application.ScreenUpdating = False
With .Range("AA1") 'range for writing
With .Resize(, 250).EntireColumn
.ClearContents 'clear
.Hidden = False
End With
.Resize(, 5).Value = Array("Project", "Hole_ID", "Sample Tag", "Depth_From", "Depth_to") '5 known headers
a = Application.Index(dict.items, 0, 0) 'read items of the dicitonary
For i = 1 To UBound(a) 'loop through them
sp = Split(a(i, 2), ":")
If sp(0) = "element" Then 'only those with leading "element" are interesting
.Cells(1, 4 + a(i, 1) * 2).Value = sp(1) 'add new element to the header
End If
Next
.Offset(1).Resize(i1, 5 + 2 * i2).Value = result 'only this size of the oversized array
For i = 1 To i2 'loop through them
With .Cells(2, 4 + i * 2).Resize(, 2)
b = (WorksheetFunction.CountA(.Resize(i1)) = 0) 'check if those columns are empty
If b Then
.EntireColumn.Hidden = (WorksheetFunction.CountA(.Resize(i1)) = 0)
Else
With .Offset(-1).Resize(i1 + 1)
.EntireColumn.AutoFit
For Each side In Array(xlEdgeLeft, xlEdgeRight)
With .Borders(side)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
Next
End With
End If
End With
Next
End With
End With
t2 = Timer
Application.StatusBar = ""
'MsgBox "writing : " & t2 - t1 & vbLf & "collecting : " & t1 - t
End Sub
the number of rows per sample are not always the same and in some cases the elements also change making this tricky. 
