因为我本人正在学习VBA ，为了煅炼一下自已，会在网上找些问题然后来练手，针对你的这个问题我的思路如下，供你参考一下。
1，首先将表中第二行，第三行的内容相连起来，然后用Split将他们拆分成数组，
2、新建一个工作表，将分解后的内容赋值到新工作表中，因为表中数值并不是单一对应（有一个对应三个值的情况，例如，23.6BB，第二行只有两个值，但下面相连却要三个数值相加）建议你在原表中最好是做成对应的，像21.5CC 一样，有规则在写代码时就会更容易些），所以将表中重复的23.6BB增加一行，并赋值
3.在新增加的工作表中用字典方法汇总数据，然后赋值。最后形成的图片效果
Sub 提取字段()
Dim ARR, I, cp, cp1, CP2, CP3, ARR1, ARR2, ARR3, arr4, RNG As Range, D As Object
ARR = Sheets(1).[A1].CurrentRegion
For I = 2 To UBound(ARR, 2)
cp = cp & ARR(2, I) & "-"
cp1 = cp1 & ARR(3, I) & "+"
Next
CP2 = Left(cp, Len(cp) - 1)
CP3 = Left(cp1, Len(cp1) - 1)
ARR1 = Split(CP2, "-")
ARR2 = Split(CP3, "+")
For I = 0 To UBound(ARR1)
Sheets(2).Cells(I + 1, 1) = ARR1(I)
Next
Set RNG = Sheets(2).Columns("a:a").Find("23.6BB")
Application.Goto RNG
RNG.Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
RNG.Offset(-1, 0).Select
ActiveCell.FormulaR1C1 = "=R[1]C"
For I = 0 To UBound(ARR2)
Sheets(2).Cells(I + 1, 2) = ARR2(I)
Next
arr4 = Sheets(2).[A1].CurrentRegion
Set D = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(arr4)
D(arr4(I, 1)) = D(arr4(I, 1)) + arr4(I, 2)
Next
Sheets(1).[H2].Resize(1, D.Count) = D.KEYS
Sheets(1).[H3].Resize(1, D.Count) = D.ITEMS
End Sub
