excel吧 关注：281,910贴子：1,556,109
- 9回复贴，共1页
不感兴趣
开通SVIP免广告
菠萝蜜
'估计需要5-10s，毕竟这个矩阵有点大：279936*253
Option Explicit
Const MaxNum As Long = 10480000
Sub abc()
Dim a, i As Long, j As Long, m As Long, t As Single
t = Timer
ReDim flag(1 To MaxNum, 1 To 1) As Long
For j = 1 To 253
a = Cells(1, j).Resize(279936).Value
For i = 1 To UBound(a)
If a(i, 1) > 0 Then
If a(i, 1) > MaxNum Then MsgBox a(i, 1): Exit Sub
flag(a(i, 1), 1) = flag(a(i, 1), 1) + 1
End If
Next
Next
For i = 1 To MaxNum
If flag(i, 1) = 1 Then m = m + 1: flag(m, 1) = i
Next
Debug.Print Timer - t
[iu:iu].ClearContents
If m > 0 Then
If m > 2 ^ 20 Then MsgBox Format(m, "无法放入单列 0"): Exit Sub
[iu1].Resize(m) = flag
End If
Debug.Print Timer - t, m
End Sub
Option Explicit
Const MaxNum As Long = 10480000
Sub abc()
Dim a, i As Long, j As Long, m As Long, t As Single
t = Timer
ReDim flag(1 To MaxNum, 1 To 1) As Long
For j = 1 To 253
a = Cells(1, j).Resize(279936).Value
For i = 1 To UBound(a)
If a(i, 1) > 0 Then
If a(i, 1) > MaxNum Then MsgBox a(i, 1): Exit Sub
flag(a(i, 1), 1) = flag(a(i, 1), 1) + 1
End If
Next
Next
For i = 1 To MaxNum
If flag(i, 1) = 1 Then m = m + 1: flag(m, 1) = i
Next
Debug.Print Timer - t
[iu:iu].ClearContents
If m > 0 Then
If m > 2 ^ 20 Then MsgBox Format(m, "无法放入单列 0"): Exit Sub
[iu1].Resize(m) = flag
End If
Debug.Print Timer - t, m
End Sub
今天刚学字典来献丑了，我认为if判断会拖慢速度，干脆先放后删，反正-200到0没几个数据。
Sub test()
On Error Resume Next
Dim arr, i As Integer, dic As Object, rng As Range
Set dic = CreateObject("Scripting.Dictionary")
For Each rng In Range("A1:IS279936")
dic.Item(rng.Value) = ""
Next rng
For i = 0 To -200 Step -1
dic.Remove (i)
Next i
arr = dic.keys
Range("IU1:IU" & dic.Count) = Application.Transpose(arr)
Range("IU:IU").Sort Range("IU1")
Set dic = Nothing
End Sub
Sub test()
On Error Resume Next
Dim arr, i As Integer, dic As Object, rng As Range
Set dic = CreateObject("Scripting.Dictionary")
For Each rng In Range("A1:IS279936")
dic.Item(rng.Value) = ""
Next rng
For i = 0 To -200 Step -1
dic.Remove (i)
Next i
arr = dic.keys
Range("IU1:IU" & dic.Count) = Application.Transpose(arr)
Range("IU:IU").Sort Range("IU1")
Set dic = Nothing
End Sub
'这么多输出数据估计用时要10s以上
Option Explicit
Const MaxNum As Long = 10480000
Sub abc()
Dim a, i As Long, j As Long, m As Long, t As Single
t = Timer
ReDim flag(1 To MaxNum, 1 To 1) As Long
For j = 1 To 253
a = Cells(1, j).Resize(279936).Value
For i = 1 To UBound(a)
If a(i, 1) > 0 Then
If a(i, 1) > MaxNum Then MsgBox a(i, 1): Exit Sub
flag(a(i, 1), 1) = flag(a(i, 1), 1) + 1
End If
Next
Next
For i = 1 To MaxNum
If flag(i, 1) = 1 Then m = m + 1: flag(m, 1) = i
Next
Debug.Print Timer - t
If m > 0 Then
Dim x As Long, y As Long
ReDim a(1 To 2 ^ 20, 1 To m \ 2 ^ 20 + 1) As Long
y = 1
For i = 1 To m
x = x + 1
a(x, y) = flag(i, 1)
If x = 2 ^ 20 Then x = 0: y = y + 1
Next
[iu1].Resize(UBound(a), UBound(a, 2)) = a
Else
MsgBox "无解"
End If
Debug.Print Timer - t, m
End Sub
Option Explicit
Const MaxNum As Long = 10480000
Sub abc()
Dim a, i As Long, j As Long, m As Long, t As Single
t = Timer
ReDim flag(1 To MaxNum, 1 To 1) As Long
For j = 1 To 253
a = Cells(1, j).Resize(279936).Value
For i = 1 To UBound(a)
If a(i, 1) > 0 Then
If a(i, 1) > MaxNum Then MsgBox a(i, 1): Exit Sub
flag(a(i, 1), 1) = flag(a(i, 1), 1) + 1
End If
Next
Next
For i = 1 To MaxNum
If flag(i, 1) = 1 Then m = m + 1: flag(m, 1) = i
Next
Debug.Print Timer - t
If m > 0 Then
Dim x As Long, y As Long
ReDim a(1 To 2 ^ 20, 1 To m \ 2 ^ 20 + 1) As Long
y = 1
For i = 1 To m
x = x + 1
a(x, y) = flag(i, 1)
If x = 2 ^ 20 Then x = 0: y = y + 1
Next
[iu1].Resize(UBound(a), UBound(a, 2)) = a
Else
MsgBox "无解"
End If
Debug.Print Timer - t, m
End Sub
