高手，大神来帮忙Excel提取数字？

Sub 字典按颜色提取排序数字()

Dim myCell, 最大使用行数, 最大使用列数, 字典 As Object, 字典1 As Object, arr, arr1, i, j

最大使用行数 = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Row - 1

最大使用列数 = ActiveSheet.UsedRange.Columns.Count + ActiveSheet.UsedRange.Column - 1

Set 字典 = CreateObject("Scripting.Dictionary")

Set 字典1 = CreateObject("Scripting.Dictionary")

On Error Resume Next

For Each myCell In Range(Cells(2, 2), Cells(最大使用行数, 最大使用列数)).Cells

If myCell.Interior.ColorIndex = 3 Then

字典.Add myCell.Value, 1

ElseIf myCell <> "" Then

字典1.Add myCell.Value, 1

End If

Next

On Error GoTo 0

arr = 字典.keys

Cells(1, 最大使用列数 + 1) = "红底数字"

For i = LBound(arr) To UBound(arr)

Cells(i + 2, 最大使用列数 + 1).Value = arr(i)

Next

arr1 = 字典1.keys

Cells(1, 最大使雀陆用列数 + 2) = "普通数字"

For j = LBound(arr1) To UBound(arr1)

Cells(j + 2, 最大使用列数 + 2).Value = arr1(j)

Next

Range(Cells(2, 最大使用列数 + 1), Cells(UBound(arr) + 2, 最大使用列顷轮顷数 + 1)).SortSpecial xlPinYin, , xlAscending

Range(Cells(2, 最大使用列数桐辩 + 2), Cells(UBound(arr1) + 2, 最大使用列数 + 2)).SortSpecial xlPinYin, , xlAscending

Set 字典 = Nothing

Set 字典1 = Nothing

End Sub

步骤及效果