EXCEL VBA的問題？

沒有具體附件，感覺樓主描述做了模擬

詳見代碼及截圖：

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