沒有具體附件,感覺樓主描述做了模擬
詳見代碼及截圖:
Sub 按鈕1_Click()
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
arr = Range("bp1:ee" & ActiveSheet.UsedRange.Rows.Count)
For j = 1 To ActiveSheet.UsedRange.Rows.Count
d.RemoveAll
For i = 1 To UBound(arr, 2)
If InStr(arr(j, i), "余") > 0 Then
brr = Split(arr(j, i), "余")
d(Val(brr(1))) = Val(brr(1))
End If
Next i
x = 0
For i = WorksheetFunction.Min(d.keys) To WorksheetFunction.Max(d.keys)
If d.exists(i) Then
x = x + 1
Cells(j, x) = Chr(69 + i)
End If
Next i
Next j
Application.ScreenUpdating = True
End Sub