[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『大量のデータの照合』(shouta)
いつも大変お世話になります。今回は処理のスピードというか、軽くする必要もある ため、アドバイスをいただければと思います。 今、Book1のSheet1に、約4万件の顧客データがあります。A列にはキーとなる契約番号が 入っています。重複はありません。 一方、Book2のSheet1には約1万件の顧客データがあります。もともとBook1を加工した ファイルですが、複雑な条件で削除したり、データ列の追加をしたり、という状態です。 やはりA列には契約番号が入っています。重複はありません。
Book1のデータからBook2に存在する契約番号のデータを抽出したいのですが、Book1の A列の横に列を挿入してCOUNTIF関数を使用して、「1」か「0」が出るようにしてみました。 データ数が少なければ全く問題なく抽出できるのですが、4万件の中から1万件を抽出す るという内容のせいか、一気にやると途中でフリーズしてしまいます。 そもそも使っている関数がまずいのかもしれませんが、うまい方法はないでしょうか? 使用する関数、あるいは組み方などのアドバイスをいただけないでしょうか? OSはWin2000、Excel2000です。PCスペックは「そろそろ買い替え」レベルだと思います。 よろしくお願いします。
シート上のデータは関数を使っているのでしょうか? 抽出したいデータは何列くらいありますか? (INA)
重複がないのであれば、Match関数がいいです。。 どうでしょうか? Option Explicit Sub てすと() Dim MyTbl As Range Dim MyKey As String Dim x As Variant With Workbooks("Book2.xls") With .Sheets("Sheet1") Set MyTbl = .Range("A1", .Range("A65536").End(xlUp)) End With End With With Workbooks("Book1.xls") With .Sheets("Sheet1") MyKey = .Range("A1").Value End With End With x = Application.Match(MyKey, MyTbl, 0) If Not IsError(x) Then MsgBox MyKey & " は、A" & x & "にあります。。" Else MsgBox MyKey & " はありません。" End If Set MyTbl = Nothing End Sub (SoulMan)
>INAさん シート上は30列程度の構成で、住所やら金額やらごちゃごちゃと入っていて、Book1だけで30M ほどになっています。なお、結構複雑な関数を含んだ列が7列程度ありますが、外部参照は していません。一旦コピーファイルを作成し、抽出に必要のない情報を削除してから再編集 することも無論可能ですが、この関数が含まれている列が抽出の条件に入っているため、これは 削除できないという状態です。 >SoulManさん 朝確認してみたら、あっという間にこんなの作ってくれてるし。本当にありがとうございます。 まだ内容を確認していないのですが、早速試させていただいて、結果についてご報告します。 何はともあれ、ありがとうございました。 (shouta)
Bookの拡張子を省略していたので訂正しました。m(._.)m ペコッ With Workbooks("Book1") ↓ With Workbooks("Book1.xls") (SoulMan)
確かに関数では固まるのね・・・_/ ̄|○ il||li マクロでやっても非力でもないPCで1分かかった_/ ̄|○ il||li Sub Test() Dim MyAry() As Variant Dim MyVal As Variant Dim MyRange1 As Range, MyRange2 As Range Dim MyLastRow1 As Long, MyLastRow2 As Long Dim RowCnt As Long, i As Long Dim MyAry1 As String Dim MyCheck As Variant With Workbooks("Book1.xls").Sheets("Sheet1") MyLastRow1 = .Range("A65536").End(xlUp).Row Set MyRange1 = .Range("A1:A" & MyLastRow1) With Workbooks("Book2.xls").Sheets("Sheet1") MyLastRow2 = .Range("A65536").End(xlUp).Row Set MyRange2 = .Range("A1:A" & MyLastRow2) End With .Range("B1:B" & MyLastRow1).Value = 0 RowCnt = -1 MyAry1 = "" '初期化 For i = 1 To MyLastRow1 MyCheck = Application.Match(.Range("A" & i).Value, MyRange2, 0) If Not IsError(MyCheck) Then RowCnt = RowCnt + 1 ReDim Preserve MyAry(0 To RowCnt) MyAry(RowCnt) = .Cells(i, 1).Address(0, 0) MyAry1 = MyAry1 & "," & MyAry(RowCnt) If (RowCnt + 1) Mod 30 = 0 Then '30行単位で処理 MyAry1 = Mid(MyAry1, 2) Range(MyAry1).Offset(0, 1).Value = 1 MyAry1 = "" '初期化 End If End If Next i If MyAry1 <> "" Then '処理すべき行が残っているなら処理 MyAry1 = Mid(MyAry1, 2) Range(MyAry1).Offset(0, 1).Value = 1 End If End With End Sub
(川野鮎太郎)
Book1に10000 Book2の20000 で40秒程でした。。 Option Explicit Sub てすと() Dim MyA As Variant, MyAry() As Variant Dim MyTbl As Range Dim i As Long, MyTimer As Single Dim x As Variant MyTimer = Timer With Workbooks("Book2.xls") With .Sheets("Sheet1") Set MyTbl = .Range("A1", .Range("A65536").End(xlUp)) End With End With With Workbooks("Book1.xls") With .Sheets("Sheet1") MyA = .Range("A1", .Range("A65536").End(xlUp)).Value ReDim MyAry(1 To UBound(MyA, 1), 1 To 1) For i = 1 To UBound(MyA, 1) x = Application.Match(MyA(i, 1), MyTbl, 0) If Not IsError(x) Then MyAry(i, 1) = 1 Next .Range("B1").Resize(UBound(MyAry, 1)).Value = MyAry End With End With MyTimer = Timer - MyTimer MsgBox Format(MyTimer, "#,##0.00") & "処理完了!!" Erase MyA, MyAry Set MyTbl = Nothing End Sub (SoulMan)
>Book1のSheet1に、約4万件の顧客データがあります ですってよ(^_^A;
(川野鮎太郎)
ありゃ、、失礼しました。m(._.)m ペコッ かくなるうえは、、、でぃくしょなりぃで・・・・・ (SoulMan)
Manちゃんの得意のやつやね^^v
(川野鮎太郎)
おまたせ(;^_^A あせあせ・・・ Book1に60000 Book2に20000 で2.6秒ほどでした。。 Option Explicit Sub てすと() Dim MyDic As Object Dim MyA As Variant, MyB As Variant, MyAry() As Variant Dim i As Long, MyTimer As Single Set MyDic = CreateObject("Scripting.Dictionary") MyTimer = Timer With Workbooks("Book2.xls") With .Sheets("Sheet1") MyB = .Range("A1", .Range("A65536").End(xlUp)).Value End With End With For i = 1 To UBound(MyB, 1) If Not MyDic.Exists(MyB(i, 1)) Then MyDic.Add MyB(i, 1), Empty Next With Workbooks("Book1.xls") With .Sheets("Sheet1") MyA = .Range("A1", .Range("A65536").End(xlUp)).Value ReDim MyAry(1 To UBound(MyA, 1), 1 To 1) For i = 1 To UBound(MyA, 1) If MyDic.Exists(MyA(i, 1)) Then MyAry(i, 1) = 1 Next .Range("B1").Resize(UBound(MyA, 1)).Value = MyAry End With End With MyTimer = Timer - MyTimer MsgBox Format(MyTimer, "#,##0.00") & "処理完了!!" Erase MyA, MyB, MyAry Set MyDic = Nothing End Sub (SoulMan)
!?工エエェ(゚〇゚ ;)ェエエ工!? まじ!!!_/ ̄|○ il||li
(ノ`O´)ノ ~┻━┻うりゃ〜!!!!なんじゃこりゃ!!! σ(^_^;)と同じデータでやったら・・・・・・ナ・ナ・ナント 0.3秒 _/ ̄|○ il||liすごすぎる・・・。 (川野鮎太郎)
報告が大変遅くなりました。上の方から順番にコピペ・ファイル名修正しながらやっていた のですが、どうしてもフリーズしてしまい、「何か間違ってるのかな?」と思って再度来て みましたら、ディクショナリーなどという聞きなれないフレーズが・・・ よく判らないながらも、同様にコピペして修正・実行したら! 3.1びょうおおおおおおおおおおおおおおおおおおお! な、なんなんですか、これは? もう、感動も驚きも通り越して、怒りが(あ、いや、ウソです) いやあ、ここ数週間の苦労が3.1秒で解消されました。 ほんっとうにありがとうございました。 しばらくの間は誰にも見せずに宝物箱にしまっておきます。 なお、内容についてはぜーんぜん理解できていないので、これからゆっくり勉強することに します。 SoulManさん、また鮎さん、どうもありがとうございました。 (shouta) #これから実務に戻りますので、もしご報告するようなことがあったら、また書き込みます。
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.