[[20050307223442]]　『大量のデータの照合』（shouta）　ページの最後に飛ぶ

『大量のデータの照合』（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ちゃんの得意のやつやね＾＾ｖ

 （川野鮎太郎）

 おまたせ(;^_^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

 (ノ｀Ｏ´)ノ ~┻━┻うりゃ～！！！！なんじゃこりゃ！！！
 σ(^_^;)と同じデータでやったら・・・・・・ナ・ナ・ナント　　　　　　　　　　　　　　　　0.3秒　＿/￣|○ il||liすごすぎる・・・。
 （川野鮎太郎）

ででえええええええええええええええええええ！！！きた！！

 報告が大変遅くなりました。上の方から順番にコピペ・ファイル名修正しながらやっていた
のですが、どうしてもフリーズしてしまい、「何か間違ってるのかな？」と思って再度来て
みましたら、ディクショナリーなどという聞きなれないフレーズが・・・
よく判らないながらも、同様にコピペして修正・実行したら！
3.1びょうおおおおおおおおおおおおおおおおおおお！
な、なんなんですか、これは？
もう、感動も驚きも通り越して、怒りが（あ、いや、ウソです）
いやあ、ここ数週間の苦労が3.1秒で解消されました。
ほんっとうにありがとうございました。
しばらくの間は誰にも見せずに宝物箱にしまっておきます。
なお、内容についてはぜーんぜん理解できていないので、これからゆっくり勉強することに
します。
SoulManさん、また鮎さん、どうもありがとうございました。
(shouta)
#これから実務に戻りますので、もしご報告するようなことがあったら、また書き込みます。

コメント返信：

[ 一覧(最新更新順) ]

[[20050307223442]] 『大量のデータの照合』（shouta） ページの最後に飛ぶ

[[20050307223442]]　『大量のデータの照合』（shouta）　ページの最後に飛ぶ