| |
さっきの投稿で取り合えず終わりしようかと思っていたんですが・・・。
今回の実験で処理が速そうな手法を出来る限り取り入れてみました。
データ数10000のテストで行ってみました。
データ数10000、欠番数3665のとき、
Test8は、「00:00:23」でした。
Test9（新規コード）は、「00:00:01」でした。
ちょっと、驚きだったので、追加投稿しました。
欠番は、ちゃんと同じ数字を拾ってきています。
Test8とTest9（新規コード）の実験コードです。
'================================================================
Sub main2()
Dim d_sht As Worksheet
Set d_sht = Workbooks.Add.Worksheets(1)
d_sht.Range("a1:k1").Value = Array("データ数", "test1", _
"test2", "test3", "test4", "test5", "test6", "test7", "text8", "test9", "欠番数")
With ThisWorkbook
.Activate
With Worksheets(1)
.Activate
idx = 2
For cnt = 10000 To 10000
.Cells.ClearContents
With .Range(.Cells(1, 1), .Cells(cnt, 1))
.Formula = "=int(rand()*" & cnt & ")+1"
.Value = .Value
End With
Call test8(ot, cnt)
d_sht.Cells(idx, 9).Value = Format(ot, "hh:mm:ss")
Call test9(ot, cnt)
d_sht.Cells(idx, 10).Value = Format(ot, "hh:mm:ss")
d_sht.Cells(idx, 11).Value = WorksheetFunction.Count(Range("j:j"))
idx = idx + 1
DoEvents
Next cnt
End With
End With
End Sub
'======================================================================
Sub test8(out_time, cnt)
st = Now()
Dim target As Range
Dim i As Integer, ret
Dim ok As Boolean
Application.ScreenUpdating = False
Set target = Range("j1:j" & cnt)
With target
.Value = Range("a1:a" & cnt).Value
.Sort Key1:=Range("J1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
For i = 1 To cnt
ret = Application.Match(i, target, 1)
ok = False
If IsError(ret) Then
ok = True
ElseIf .Cells(ret).Value <> i Then
ok = True
End If
If ok Then
Cells(j + 1, 9).Value = i
j = j + 1
End If
Next
.ClearContents
End With
Application.ScreenUpdating = True
out_time = Now() - st
End Sub
'=======================================================================
Sub test9(out_time, cnt)
st = Now()
Dim target As Range
Dim ans
Application.ScreenUpdating = False
Set target = Range("k1:k" & cnt)
With target
.Value = Range("a1:a" & cnt).Value
.Sort Key1:=Range("k1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
ad = .Address
f1 = .Cells(1).Address(False, False)
With Range("l1:l" & cnt)
.Formula = "=IF(ISERROR(MATCH(ROW(" & f1 & ")," & ad & ",1)),ROW(" & f1 & ")," & _
"IF(ROW(" & f1 & ")<>INDEX(" & ad & ",MATCH(ROW(" & f1 & ")," & ad & ",1),1)," & _
"ROW(" & f1 & "),""×""))"
ans = WorksheetFunction.Transpose(.Cells)
.ClearContents
End With
wk = Filter(ans, "×", False)
If UBound(wk) - LBound(wk) + 1 > 0 Then
ReDim myarray(1 To UBound(wk) - LBound(wk) + 1, 1 To 1)
i = 1
For Each a In wk
myarray(i, 1) = a
i = i + 1
Next
Range(Cells(LBound(myarray(), 1), 10), Cells(UBound(myarray(), 1), 10)).Value = myarray()
End If
.ClearContents
End With
Application.ScreenUpdating = True
out_time = Now() - st
End Sub
あまりに違うのでどこかにミスがあるかもしれないと思い、
皆さんにも試していただこうとコードを載せました。
時間は、ともかく、確かに体感で速かったです。
ちなみにデータ数30000でも試しましたが、3秒程度でした。
ここで皆さんにご協力いただいて本当に色んなサンプルを試行することが
できました。
重ね重ね、感謝いたします。ありがとうございました。
|
|
ichinose
- 04/8/6(金) 9:48 -
