Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


64621 / 76732 ←次へ | 前へ→

【16691】Re:イミディエイトウインドウ 追伸
発言  ichinose  - 04/8/6(金) 9:48 -

引用なし
パスワード
   さっきの投稿で取り合えず終わりしようかと思っていたんですが・・・。

今回の実験で処理が速そうな手法を出来る限り取り入れてみました。


データ数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秒程度でした。


ここで皆さんにご協力いただいて本当に色んなサンプルを試行することが
できました。
重ね重ね、感謝いたします。ありがとうございました。

1 hits

【16617】欠番を発見したい hisao 04/8/4(水) 11:02 質問
【16618】Re:欠番を発見したい つん 04/8/4(水) 11:20 回答
【16639】Re:欠番を発見したい Asaki 04/8/4(水) 17:53 回答
【16642】Re:欠番を発見したい Asaki 04/8/4(水) 19:41 発言
【16648】Re:欠番を発見したい ichinose 04/8/5(木) 8:49 発言
【16649】Re:欠番を発見したい でれすけ 04/8/5(木) 9:32 発言
【16652】Re:欠番を発見したい hisao 04/8/5(木) 10:44 お礼
【16653】イミディエイトウインドウ つん 04/8/5(木) 11:13 発言
【16654】Re:イミディエイトウインドウ でれすけ 04/8/5(木) 11:22 発言
【16656】Re:イミディエイトウインドウ hisao 04/8/5(木) 11:59 お礼
【16666】Re:イミディエイトウインドウ つん 04/8/5(木) 13:14 発言
【16668】Re:イミディエイトウインドウ Asaki 04/8/5(木) 13:15 回答
【16688】Re:イミディエイトウインドウ ichinose 04/8/6(金) 1:30 発言
【16691】Re:イミディエイトウインドウ 追伸 ichinose 04/8/6(金) 9:48 発言
【16693】Re:イミディエイトウインドウ hisao 04/8/6(金) 12:00 お礼

64621 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free