Dim a, b, arr(), i, ff As Boolean
Application.ScreenUpdating = False
a = Columns(256).End(xlToLeft).Column
b = Rows(65000).End(xlUp).Row
ff = False
ReDim arr(a * b - 1)
i = 0
'讀取所有結果
For Each acell In Range(Cells(1, 1), Cells(b, a))
arr(i) = acell.Value
acell.Select
i = i + 1
Next
'新表展示
For Each sh In Sheets
If sh.Name = "結果" Then
ff = True
End If
Next
If ff = False Then
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "結果"
End If
Sheets("結果").Select
Cells(1, 1).Select
[a1].Resize(UBound(arr)) = Application.Transpose(arr)
'排序
ActiveWorkbook.Worksheets("結果").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("結果").Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("結果").Sort
.SetRange Range("A1:A" & a * b - 1)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'刪除重復
For i = 1 To a * b - 1
If a * b - i > 1 Then
If Cells(a * b - i, 1).Value = Cells(a * b - i - 1, 1).Value Then
Cells(a * b - i - 1, 1).Delete Shift:=xlUp
End If
End If
Next i
End Sub
啰唆壹點 可以達成 最終結果展示在 結果表裏面
改進了下 用了 字典
Sub aa()
Application.ScreenUpdating = False
Dim dic As Object, I&, arr, r, a, b
a = Columns(256).End(xlToLeft).Column
b = Rows(65000).End(xlUp).Row
Set dic = CreateObject("Scripting.Dictionary")
ReDim arr(a * b - 1)
I = 0
'讀取所有結果
For Each acell In Range(Cells(1, 1), Cells(b, a))
arr(I) = acell.Value
acell.Select
I = I + 1
Next
For I = 0 To UBound(arr)
r = dic(arr(I))
Next
For Each sh In Sheets
If sh.Name = "結果" Then
ff = True
End If
Next
If ff = False Then
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "結果"
End If
Sheets("結果").Select
Cells(1, 1).Select
[a1].Resize(dic.Count, 1) = Application.Transpose(dic.Keys)
Application.ScreenUpdating = True
End Sub