VBAでExcelシートA列にある管理番号(1から付番)から、欠番を探して返すマクロを書いたのですが、データが20000件程度あり、

Visual Basic | Excel67閲覧xmlns="http://www.w3.org/2000/svg">500

ベストアンサー

0

ThanksImg質問者からのお礼コメント

こちらの方法を試したところ、劇的な速度で管理番号を取得することができました。配列を使うにも、結局頭の柔らかさが必要なのだと思い知りました。大変ありがとうございました!!

お礼日時:7/24 10:16

その他の回答(5件)

1

1から始まる連番から欠番をみつけるだけなら もっと単純なやり方で済むと思います。 データを配列に入れ、ループで検査。 ループ内で作った連番とデータを比較し、違っていればそれは欠番ってことで いいんじゃないでしょうか。 データ件数: 20,000件 欠番の位置: 12,000件目 処理時間: 0.08秒 Function 欠番(検査範囲 As Range) As Long ’セル範囲のデータを配列に入れる Dim data: data = 検査範囲 Dim i&, num& For i = LBound(data) To UBound(data) num = num + 1 ’比較対象として連番を作る ’配列の要素と比較 If num <> data(i, 1) Then 欠番 = num Exit Function End If Next End Function

1人がナイス!しています

0

私の環境下で20000行で1.5秒程度です。 欠番と重複の番号をメッセージボックスに表示します。 元々のA列が昇順になっているなら作業用シートを作らず瞬時で終わるのですが、A列が昇順になっていないかもしれないので、 1.作業用シートを追加し 2.A列を作業用シートにコピーし 3.作業用シートでA列を昇順にソートし 4.検索を行い 5.作業用シートを破棄 します。 Dim LastR, R, Lost, Dupl, N, i Dim WS As Worksheet LastR = Cells(Rows.Count, 1).End(xlUp).Row Columns(1).Copy Lost = "" Dupl = "" With Worksheets.Add     .Cells(1, 1).PasteSpecial     .Columns(1).Sort key1:=.Cells(1, 1), order1:=xlAscending     R = 1     N = 1     Do: DoEvents         If .Cells(R, 1) <> N Then             If N < .Cells(R, 1) Then                 Lost = Lost & N & ","                 N = N + 1             Else                 Dupl = Dupl & .Cells(R, 1) & ","                 R = R + 1             End If         Else             R = R + 1             N = N + 1         End If     Loop Until R = LastR     Application.DisplayAlerts = False     .Delete     Application.DisplayAlerts = True End With MsgBox "欠番:" & Lost & vbCr & _        "重複:" & Dupl

管理番号のあるA列は、昇順になっているとは限らないものでして、情報の提示があまく申し訳ありません。また作業用シートも作成しない方向で考えたいので、この方法は別の機会に使わせていただきます。ありがとうございました。

0

作業用シートを作成できるのであれば、以下のコードでも少しは早いですよ。ダメだったら、シートを追加ということもでもOKですね。 Dim Get_kanri As Long Dim ws2 As Worksheet, rg As Range, ii As Long ''管理番号を作業用シートにコピーする。 Set ws2 = Worksheets("sheet2") ''作業用シート With Range("A1", Cells(Rows.CountLarge, "A").End(xlUp)) ws2.Range("A:A").ClearContents .Copy ws2.Range("A1") Set rg = ws2.Range("A1").Resize(.Rows.CountLarge) End With ''管理番号を昇順に並べ替える。 With ws2.Sort .SortFields.Clear .SortFields.Add2 Key:=rg, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SetRange rg .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlStroke .Apply End With ''欠番を求める。 If (ws2.Range("A1").Value <> 1) Then Get_kanri = 1 Else Get_kanri = rg(rg.CountLarge) + 1 ''仮値(最大値+1) For ii = 2 To rg.Rows.CountLarge If (ws2.Cells(ii - 1, "A").Value + 1 <> ws2.Cells(ii, "A").Value) Then Get_kanri = ii Exit For End If Next End If MsgBox "Get_kanri=" & Get_kanri

0

辞書機能と2次元配列を使いました。 C列に結果が表示されます。 Sub test() Dim no As Object Dim i, l, m As Long Dim lastd As Long lastd = Cells(Rows.Count, 1).End(xlUp).Row Dim Get_kanri(60000, 1) As Long Set no = CreateObject("Scripting.Dictionary") For i = 1 To lastd no.Add Cells(i, 1).Value, "0" Next i max1 = WorksheetFunction.Max(Columns("A")) l = 0 '既設管理番号1から最大値m1+1まで1ずつ加えて確認する。 For m = 1 To max1 If no.Exists(m) = False Then Get_kanri(l, 0) = m l = l + 1 End If Next m Range(Cells(1, 3), Cells(60000, 3)) = Get_kanri Range("C1:C60000").Replace What:="0", Replacement:="", LOOKAT:=xlWhole End Sub

Dictionaryを使っているのですが、今回Dictionaryのところで躓き、また60000件の部分でも定数を使わない方法がないか考えていました。しかし自分のものにできませんでした。別の機会に使わせていただきます。ありがとうございました。