Hi Roldy. You can trial this VBA. HTH. Dave
Sub test()Dim Cnt As Integer, Cnt1 As Integer, Cnt2 As Integer, Rng As Range
Dim Lastrow As Integer, NameArr() As Variant, Cnter As Integer
Dim TempStr As String, Splitter As Variant, Depth As Double
'Data in "A1"A" & etc)
'Depth output in "C"; Wt/ft in "D"
With Sheets("Sheet1")
Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
'sort unique into array
For Cnt = 1 To Lastrow
For Cnt1 = 1 To (Cnt - 1)
If LCase(.Range("A" & Cnt1).Value) = _
LCase(.Range("A" & Cnt).Value) Then ' more than one entry
GoTo Bart
End If
Next Cnt1
Cnter = Cnter + 1
ReDim Preserve NameArr(Cnter)
NameArr(Cnter - 1) = .Range("A" & Cnt).Value
Bart:
Next Cnt
On Error GoTo ErFix
Application.ScreenUpdating = False
'loop unique arr & split into depth("C") and wt/ft("D")
For Cnt2 = LBound(NameArr) To UBound(NameArr) - 1
TempStr = NameArr(Cnt2) & "x"
Splitter = Split(TempStr, "x")
Depth = CDbl(Right(Splitter(0), Len(Splitter(0)) - 1))
.Range("C" & Cnt2 + 1).Value = Depth
.Range("D" & Cnt2 + 1).Value = Splitter(1) 'wt/ft
Next Cnt2
'sort descending
Set Rng = .Range(.Cells(1, "C"), .Cells(Lastrow, "D"))
Rng.Sort Key1:=Range("C1"), Order1:=xlDescending, _
Orientation:=xlSortColumns
'Add "W" to depth
For Cnt2 = LBound(NameArr) To UBound(NameArr) - 1
.Range("C" & Cnt2 + 1).Value = "W" & .Range("C" & Cnt2 + 1).Value
Next Cnt2
End With
ErFix:
Application.ScreenUpdating = True
End Sub