Excel VBA質問箱 IV

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

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


11329 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

【16617】欠番を発見したい
質問  hisao E-MAIL  - 04/8/4(水) 11:02 -

引用なし
パスワード
   いつもお世話になります。
A列に1〜100の数字が入っているとします(重複もあります)
1〜100の数字の内欠番が有れば見つけたいのですが、方法は無いでしょうか。

【16618】Re:欠番を発見したい
回答  つん E-MAIL  - 04/8/4(水) 11:20 -

引用なし
パスワード
   hisao さん、こんにちは

>いつもお世話になります。
>A列に1〜100の数字が入っているとします(重複もあります)
>1〜100の数字の内欠番が有れば見つけたいのですが、方法は無いでしょうか。

なんかめちゃくちゃベタなやり方なような気もしますが、
こんなんでどうでしょうか?

Sub test()

  Dim i As Long
  Dim r As Range
  Dim rTarget As Range
  
  Set rTarget = Range(Cells(1, 1), Cells(Range("a65536").End(xlUp).Row, 1))
  
  For i = 1 To 100
    Set r = rTarget.Find(i, LookAt:=xlWhole)
    If r Is Nothing Then
      Debug.Print i
    End If
  Next i
  
  Set r = Nothing
  Set rTarget = Nothing

End Sub

別に重複している場合は、その情報を取得しなくていいんですよね?

【16639】Re:欠番を発見したい
回答  Asaki  - 04/8/4(水) 17:53 -

引用なし
パスワード
   こんにちは。

速度度外視な感じで。
B列を作業列として使っています。
Sub test()
  Dim c    As Range
  With Range("B1:B100")
    .Formula = "=CountIf(A$1:A$100,Row())"
    For Each c In .Cells
      If c.Value = 0 Then Debug.Print c.Row
    Next c
    .ClearContents
  End With
End Sub

【16642】Re:欠番を発見したい
発言  Asaki  - 04/8/4(水) 19:41 -

引用なし
パスワード
   間違ってる気がしたんですが、やっぱり間違ってました。

>.Formula = "=CountIf(A$1:A$100,Row())"

.Formula = "=CountIf(A:A,Row())"

【16648】Re:欠番を発見したい
発言  ichinose  - 04/8/5(木) 8:49 -

引用なし
パスワード
   hisaoさん、つんさん、Asakiさん、おはようございます。

自由研究してみました。
こういう検索は、私は、「Asakiさんのようなコードが処理速度はより速い」と
思っていて同様なご質問の回答にはAsakiさんが投稿されたようなコードを記述した
覚えがあります(コードは、処理速度だけが指標とはいえませんが・・・)。
いくつかサンプルコードを作って(つんさんとAsakiさんのコードも貸して頂いて)みました。
尚、結果は後述しますが、これはコードの優劣でなく、純粋にVBAの実験だとご了承ください。

以下のコードで実験しました(実は、昨日から走らせて中々終わらないんで途中で終わらせたんですが、4時間かかりました)。
コードは、6つのサンプルコードの処理時間を新規ブックに記録したものです。

'===================================================================
Sub main()
  Dim d_sht As Worksheet
  Set d_sht = Workbooks.Add.Worksheets(1)
  d_sht.Range("a1:h1").Value = Array("データ数", "test1", _
        "test2", "test3", "test4", "test5", "test6", "欠番数")
  With ThisWorkbook
   .Activate
   With Worksheets(1)
     .Activate
     idx = 2
     For cnt = 100 To 3000 Step 1000 '←ここの値を変更すると
'                       短時間のテストも可能です
      .Cells.ClearContents
      With .Range(.Cells(1, 1), .Cells(cnt, 1))
        .Formula = "=int(rand()*" & cnt & ")+1"
        .Value = .Value
        End With
      Call test1(ot, cnt)
      d_sht.Cells(idx, 1).Value = cnt
      d_sht.Cells(idx, 2).Value = Format(ot, "hh:mm:ss")
      Call test2(ot, cnt)
      d_sht.Cells(idx, 3).Value = Format(ot, "hh:mm:ss")
      Call test3(ot, cnt)
      d_sht.Cells(idx, 4).Value = Format(ot, "hh:mm:ss")
      Call test4(ot, cnt)
      d_sht.Cells(idx, 5).Value = Format(ot, "hh:mm:ss")
      Call test5(ot, cnt)
      d_sht.Cells(idx, 6).Value = Format(ot, "hh:mm:ss")
      Call test6(ot, cnt)
      d_sht.Cells(idx, 7).Value = Format(ot, "hh:mm:ss")
      d_sht.Cells(idx, 8).Value = WorksheetFunction.Count(Range("b:b"))
      idx = idx + 1
      DoEvents
      Next cnt
     End With
   End With
End Sub
'========================================================================
Sub test1(out_time, cnt)
'Asakiさんのコードを参考
  st = Now()
  Dim ans As Range
  Dim rng As Range
  Set rng = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
  ad = rng.Address
  With Range("c1:c" & cnt)
    .Formula = "=CountIf(" & ad & ",Row())"
    For Each cc In .Cells
     If cc.Value = 0 Then
       Cells(idx + 1, 2).Value = cc.Row
       idx = idx + 1
       End If
     Next
    .ClearContents
    End With
  Set rng = Nothing
  out_time = Now() - st
End Sub
'=========================================================
Sub test2(out_time, cnt)
'Asakiさんのコードをちょっと変更
  st = Now()
  Dim ans As Range
  Dim rng As Range
  Set rng = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
  ad = rng.Address
  With Range("d1:d" & cnt)
    .Formula = "=if(CountIf(" & ad & ",Row())=0,row(),"""")"
    .Value = .Value
    On Error Resume Next
    Set ans = .SpecialCells(xlCellTypeConstants)
    If Err.Number = 0 Then
      For Each cc In ans
       Cells(idx + 1, 3).Value = cc.Value
       idx = idx + 1
       Next
      End If
    .ClearContents
    End With
  Set rng = Nothing
  out_time = Now() - st
End Sub
'============================================================
Sub test3(out_time, cnt)
'Asakiさんのコードをちょっと変更してループをなくしたコード
  st = Now()
  Dim ans As Range
  Dim rng As Range
  Set rng = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
  ad = rng.Address
  With Range("e1:e" & cnt)
    .Formula = "=if(CountIf(" & ad & ",Row())=0,row(),"""")"
    .Value = .Value
    On Error Resume Next
    Set ans = .SpecialCells(xlCellTypeConstants)
    If Err.Number = 0 Then
      ans.Copy Range("d1")
      End If
    .ClearContents
    End With
  Set rng = Nothing
  out_time = Now() - st
End Sub
'====================================================================
Sub test4(out_time, cnt)
'つんさんのコード
  st = Now()
  Dim i As Long
  Dim r As Range
  Dim rTarget As Range
  Set rTarget = Range(Cells(1, 1), Cells(Range("a65536").End(xlUp).Row, 1))
  For i = 1 To cnt
    Set r = rTarget.Find(i, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True)
    If r Is Nothing Then
      Cells(j + 1, 5).Value = i
      j = j + 1
    End If
  Next i
  Set r = Nothing
  Set rTarget = Nothing
  out_time = Now() - st
End Sub
'==================================================================
Sub test5(out_time, cnt)
'Evaluateメソッドで配列を使用したコード
  st = Now()
  Dim rng As Range
  Dim ans
  Set rng = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
  ad = rng.Address
  ans = Evaluate("transpose(if(countif(" & ad & _
       ",row(a1:a" & cnt & "))=0,row(a1:a" & cnt & "),""×""))")
  wk = Filter(ans, "×", False)
  i = 1
  For Each a In wk
   Cells(i, 6).Value = a
   i = i + 1
   Next
  Set rng = Nothing
  out_time = Now() - st
End Sub
'=====================================================================
Sub test6(out_time, cnt)
'Countifでべたで数えた方法
  st = Now()
  Dim i As Long
  Dim r As Range
  Dim rTarget As Range
  Set rTarget = Range(Cells(1, 1), Cells(Range("a65536").End(xlUp).Row, 1))
  With WorksheetFunction
    For i = 1 To cnt
     If .CountIf(rTarget, i) = 0 Then
      Cells(j + 1, 7).Value = i
      j = j + 1
      End If
     Next i
    End With
  Set rTarget = Nothing
  out_time = Now() - st
End Sub


というコードで実験してみました。
Findメソッドは、文字列比較をするので処理自体は遅いかも・・・
という予想(中身は知らないので根拠はありませんが)をしていました。

途中で終わらせたのでそこまでの結果ですが、以下のようになっています。

データ数 test1  test2  test3  test4  test5  test6 欠番数
100   0:00:01 0:00:00 0:00:00 0:00:00 0:00:01 0:00:00 35
1100   0:00:04 0:00:04 0:00:02 0:00:08 0:00:04 0:00:04 412
2100   0:00:11 0:00:11 0:00:06 0:00:17 0:00:11 0:00:11 794
3100   0:00:19 0:00:20 0:00:13 0:00:31 0:00:19 0:00:20 1162
4100   0:00:31 0:00:32 0:00:23 0:00:49 0:00:31 0:00:32 1509
5100   0:00:44 0:00:45 0:00:34 0:01:09 0:00:44 0:00:46 1881
6100   0:01:00 0:01:01 0:00:49 0:01:35 0:01:00 0:01:03 2231
7100   0:01:21 0:01:22 0:01:08 0:02:04 0:01:21 0:01:23 2613
8100   0:01:49 0:01:46 0:01:31 0:02:38 0:01:45 0:01:50 2999
9100   0:02:12 0:02:12 0:01:55 0:03:13 0:02:11 0:02:14 3357
10100  0:02:44 0:02:42 0:02:22 0:03:53 0:02:42 0:02:45 3701
11100  0:03:14 0:03:14 0:02:54 0:04:34 0:03:13 0:03:18 4118
12100  0:03:50 0:03:49 0:03:28 0:05:16 0:03:50 0:03:53 4432
13100  0:04:31 0:04:32 0:04:07 0:06:06 0:04:28 0:04:35 4825
14100  0:05:14 0:05:12 0:04:47 0:06:58 0:05:11 0:05:16 5135
15100  0:06:01 0:06:03 0:05:34 0:07:57 0:05:59 0:06:04 5566
16100  0:06:53 0:06:56 0:06:26 0:08:55 0:06:52 0:06:58 5946
計    *****  *****  *****  *****  *****  *****  *****
137700  0:40:39 0:40:41 0:36:19 0:56:03 0:40:22 0:41:12 50716
速度順位 3      4    1    6    2    5    

以上が途中までの結果ですが、
一応、処理速度の順位は付けましたが、「大きい変化はないなあ」
というのが私の感想でした。

それにデータ数がこれ以上に大きくなったとき、配列を使った手法はExcelが
我慢できるかという懸念もあります。

尚、実験は、win98se & Excel2000で行いました。
PCのスペックによって数値が違うのは当然ですが、
結果からの考察をよかったらしてみて下さい。

【16649】Re:欠番を発見したい
発言  でれすけ  - 04/8/5(木) 9:32 -

引用なし
パスワード
   みなさんこんにちわ

私はこういう場合、Match関数を結構よく使います。

Sub sample()

Dim target As Range
Dim i As Integer, ret

Set target = Range("A1:A100")

For i = 1 To 100
If IsError(Application.Match(i, target, False)) Then Debug.Print i
Next

End Sub

【16652】Re:欠番を発見したい
お礼  hisao E-MAIL  - 04/8/5(木) 10:44 -

引用なし
パスワード
   つん様、ASAKI様、ICHINOSE様、でれすけ様 早速のお返事
大変有り難う御座いました。
ところで 誠にお恥ずかしい事ですが debug.print の使い方がよく解りません。
検索結果が どの様に出てくるのでしょうか、申し訳ありませんが どなたかお教え下さい。

▼でれすけ さん:
>みなさんこんにちわ
>
>私はこういう場合、Match関数を結構よく使います。
>
>Sub sample()
>
>Dim target As Range
>Dim i As Integer, ret
>
>Set target = Range("A1:A100")
>
>For i = 1 To 100
> If IsError(Application.Match(i, target, False)) Then Debug.Print i
>Next
>
>End Sub

【16653】イミディエイトウインドウ
発言  つん E-MAIL  - 04/8/5(木) 11:13 -

引用なし
パスワード
   皆さん、おはようございます。

>ところで 誠にお恥ずかしい事ですが debug.print の使い方がよく解りません。
>検索結果が どの様に出てくるのでしょうか、申し訳ありませんが どなたかお教え下さい。

VBEの「表示」−「イミディエイトウインドウ」で、イミディエイトウインドウっちゅーもんが表示されます。
実行すると、そこに結果が表示されています。
ちなみに、ステップ実行中に、このウインドウで「? 変数」としてリターンしたら、
変数のその時点での中身が表示されたりして、便利どす。

ichinoseさん
自由研究すごいですね!
私は、とにかく速度とか考えないで「実現出来るコード」を一つ考えるのが精一杯。
もっと柔軟にいろんなやり方を考えられて、その中でベストなやり方をチョイス出来るようにならんといけませんね。

Asakiさんやでれすけさんのコードも参考になります♪
ところで、Match関数をヘルプで見ると、3つ目の引数は「1,0,-1」のどれかを指定する・・とありますが、

Application.Match(i, target, False)

この「False」ってどーゆーことなんでしょうか?

【16654】Re:イミディエイトウインドウ
発言  でれすけ  - 04/8/5(木) 11:22 -

引用なし
パスワード
   こんにちは
すみません間違いました。

>Application.Match(i, target, False)
>
>この「False」ってどーゆーことなんでしょうか?
Vlookupとごっちゃになってまちがちゃいました。
Application.Match(i, target, 0)
に直してください。

False=0 なので、結果的には問題なく動くので、
テストした時気づきませんでした。

混乱させてすみません

【16656】Re:イミディエイトウインドウ
お礼  hisao E-MAIL  - 04/8/5(木) 11:59 -

引用なし
パスワード
   つんさん 有り難う御座います。
イミテイドウインドウ便利ですね。知りませんでした。
これを マクロで msgboxかなんかに 表示する方法もあるのですか?
欠番を全て一挙にエクセルの画面に表示する方法です。
素人の質問ですみません。

▼つん さん:
>皆さん、おはようございます。
>
>>ところで 誠にお恥ずかしい事ですが debug.print の使い方がよく解りません。
>>検索結果が どの様に出てくるのでしょうか、申し訳ありませんが どなたかお教え下さい。
>
>VBEの「表示」−「イミディエイトウインドウ」で、イミディエイトウインドウっちゅーもんが表示されます。
>実行すると、そこに結果が表示されています。
>ちなみに、ステップ実行中に、このウインドウで「? 変数」としてリターンしたら、
>変数のその時点での中身が表示されたりして、便利どす。
>
>ichinoseさん
>自由研究すごいですね!
>私は、とにかく速度とか考えないで「実現出来るコード」を一つ考えるのが精一杯。
>もっと柔軟にいろんなやり方を考えられて、その中でベストなやり方をチョイス出来るようにならんといけませんね。
>
>Asakiさんやでれすけさんのコードも参考になります♪
>ところで、Match関数をヘルプで見ると、3つ目の引数は「1,0,-1」のどれかを指定する・・とありますが、
>
>Application.Match(i, target, False)
>
>この「False」ってどーゆーことなんでしょうか?

【16666】Re:イミディエイトウインドウ
発言  つん E-MAIL  - 04/8/5(木) 13:14 -

引用なし
パスワード
   でれすけさん

わかりました(^^)


hisao さん

>つんさん 有り難う御座います。
>イミテイドウインドウ便利ですね。知りませんでした。
>これを マクロで msgboxかなんかに 表示する方法もあるのですか?
>欠番を全て一挙にエクセルの画面に表示する方法です。
>素人の質問ですみません。

ichinoseさんが、セルに書き出していっているので、
ichinoseさんのコードが参考になるはずです。
「test6」とかがわかりやすいかなー?

【16668】Re:イミディエイトウインドウ
回答  Asaki  - 04/8/5(木) 13:15 -

引用なし
パスワード
   みなさま、こんにちは。

>欠番を全て一挙にエクセルの画面に表示する方法です。
ichinose さんのテストで最速だったコードから、テスト関連の処理を削除して
Sub test3()
  Dim ans       As Range
  Dim rng       As Range

  Set rng = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
  With Range("b1:b100")
    .Formula = "=if(CountIf(" & rng.Address & ",Row())=0,row(),"""")"
    .Value = .Value
    On Error Resume Next
    Set ans = .SpecialCells(xlCellTypeConstants)
    If Err.Number = 0 Then
      ans.Copy Range("C1")
    End If
    .ClearContents
  End With
  Set rng = Nothing
End Sub

B列を作業列として使い、C列に欠番が表示されます。


ichinose さん
自由研究、参考になります。
個人的には、多分、でれすけ さんご提案のMatchが速いのではと思います。
但し、データが昇順または降順になっている または、並べ替えても良い という前提の場合ですが。

Evaluate が、結構速いんですね。
これがちょっと意外でした。

【16688】Re:イミディエイトウインドウ
発言  ichinose  - 04/8/6(金) 1:30 -

引用なし
パスワード
   みなさん、こんばんは。

>個人的には、多分、でれすけ さんご提案のMatchが速いのではと思います。
>但し、データが昇順または降順になっている または、並べ替えても良い という前提の場合ですが。

Match関数、速かったですよ!!ソートされていない場合のでれすけさんのコードでも
かなりものです。

今回は、データ数10000のみのテストで行ってみました。
他のコードも ScreenupdatingのFalse、Trueや
配列でセルに書き込みできるコードは、そのようにしてみました。
例えば、Test2は、
'============================================================
Sub test2(out_time, cnt)
  st = Now()
  Dim myarray()
  Dim ans As Range
  Dim rng As Range
  Set rng = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
  ad = rng.Address
  With Range("d1:d" & cnt)
    .Formula = "=if(CountIf(" & ad & ",Row())=0,row(),"""")"
    .Value = .Value
    On Error Resume Next
    Set ans = .SpecialCells(xlCellTypeConstants)
    If Err.Number = 0 Then
      ReDim myarray(1 To ans.Count, 1 To 1)
      For Each cc In ans
       myarray(idx + 1, 1) = cc.Value
       idx = idx + 1
       Next
      Range(Cells(LBound(myarray(), 1), 3), Cells(UBound(myarray(), 1), 3)).Value = myarray()
      End If
    .ClearContents
    End With
  Set rng = Nothing
  out_time = Now() - st
End Sub
こんな感じに・・・(これで速度は上がっています、Test3より速い)。

全部載せると長くなるので、でれすけさんのコードだけテスト用に変更したものを
記述します。
'=======================================================
Sub test7(out_time, cnt)
  st = Now()
  Dim target As Range
  Dim i As Integer, ret
  Application.ScreenUpdating = False
  Set target = Range("A1:A" & cnt)
  For i = 1 To cnt
   If IsError(Application.Match(i, target, False)) Then
    Cells(j + 1, 8).Value = i
    j = j + 1
    End If
   Next
  Application.ScreenUpdating = True
  out_time = Now() - st
End Sub

これをAsakiさんがおっしゃっているように並べ替えも行うコードは
以下のコードで実行してみました。

'==================================================================
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

データ数10000、欠番数3661のとき、

前回までのTest1〜Test6の中では、

最速がTest5の「00:02:17」でした。

これに対し、Test7は「00:00:47」でソートなしでもかなり速い結果をだしています。

さらに、Test8は、「00:00:22」でした。

つんさんもAsakiさんも速度というキーワードがあれば、もっと違うコードの投稿を
されていたと思います。

いろんな手法でのコード、予想はできても中々確認までしていられなかったので
このご質問を利用して、いろんなサンプルコードで確認する事ができました。
皆さん、ありがとうございました。

【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秒程度でした。


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

【16693】Re:イミディエイトウインドウ
お礼  hisao E-MAIL  - 04/8/6(金) 12:00 -

引用なし
パスワード
   つんさん、asakiさん、ichinoseさん 有難う御座いました。

▼Asaki さん:
>みなさま、こんにちは。
>
>>欠番を全て一挙にエクセルの画面に表示する方法です。
>ichinose さんのテストで最速だったコードから、テスト関連の処理を削除して
>Sub test3()
>  Dim ans       As Range
>  Dim rng       As Range
>
>  Set rng = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
>  With Range("b1:b100")
>    .Formula = "=if(CountIf(" & rng.Address & ",Row())=0,row(),"""")"
>    .Value = .Value
>    On Error Resume Next
>    Set ans = .SpecialCells(xlCellTypeConstants)
>    If Err.Number = 0 Then
>      ans.Copy Range("C1")
>    End If
>    .ClearContents
>  End With
>  Set rng = Nothing
>End Sub
>
>B列を作業列として使い、C列に欠番が表示されます。
>
>
>ichinose さん
>自由研究、参考になります。
>個人的には、多分、でれすけ さんご提案のMatchが速いのではと思います。
>但し、データが昇順または降順になっている または、並べ替えても良い という前提の場合ですが。
>
>Evaluate が、結構速いんですね。
>これがちょっと意外でした。

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