ロット数で抽出したい

質問

多数の品名があり、それぞれ複数のロットのデータがあります。
例えば、
Ａ列　　Ｂ列　　　　　　Ｃ列
品名Ａ　ロットNo.123　　データ0.1
品名Ｂ　ロットNo.235　　データ0.5
品名Ｃ　ロットNo.567　　データ3.1
品名Ａ　ロットNo.125　　データ0.2
品名Ｄ　ロットNo.425　　データ1.2
　：　　　　：　　　　　　：
と言う感じで、品名は1000以上、全ロット数は30000ほどあります。
ここでロット数が４ロット以上の品名だけを抽出してデータ解析をしたいのですが、うまい方法はあるでしょうか？
一応、Ｄ列の一行目に
=countif($A$1:$A$30000,A1)
と入力後、オートフィルで全てコピーしてやれば後はオートフィルターで４以上を指定してやればよいのですが、この数式をオートフィルでコピーする際に非常に時間がかかります（20分くらい)。
もっと簡単にやれる方法があれば教えて頂けると助かります。

回答No.1

dac203 · ベストアンサー

データの並べ替えを行っても問題がなければ下記の方法で少しは早くなると思います（COUNTIFの実行回数が減るはずなので・・・）。

・品名順に並べ替える
・D2に=IF(A2=A1,D1,COUNTIF($A$2:$A$30000,A2))
・式をD3～D30000までコピーする
・オートフィルタでD列が4以上のフィルタをかける

お礼

早速やってみました。
少しどころか、非常に早く処理が可能でした。
一分もかかりません。
COUNTIFの実行回数を減らすのが有効なのですね。
ありがとうございました！

回答No.3

Wendy02

こんばんは。
十分に検証を重ねてはいますが、出来上がりは、あまり芳しい状態ではありませんでした。内容的には、簡単ですが、いかに速くする、ということを目的にして作ったのですが、残念ながら、せいぜい６分を切る程度でした。問題になったのは、Excelのデータベース演算が標準で、ワイルドカードになっていること、CountIf を使うと、ひじょうに遅くなるということでした。この処理に手間が掛かりました。

途中で、これは、データベースのグループ化で抽出したほうが速いと気が付きました。

出力値は、E列から、３列を使いますが、K列にクライテリアを置くようになっています。
テンポリー出力したものは、最後に削除しています。

必ず、<標準モジュール>に貼り付けしてくださるようにお願いします。
３万件で、６分というところが目処です。あまり長い場合は、どこかでトラブルが発生しているかもしれません。予想のつかないトラブルがあるかもしれません。
ところどころで、画面を更新させるようにはしています。

今回、途中で止めるオプションはつけてありませんが、Ctrl+Break で止まります。しかし、オブジェクトを抱え込んだままですので、できればそのまま使わずに、一旦、終了させたほうが安全です。

'<標準モジュール>
Option Explicit

Sub PickupCount()
Dim rng As Range
Dim a(), ar()
Dim rtn As Long, buf As Long
Dim i As Long
Dim rnum As Variant, rngValue As Variant
Dim CriteriaRng As Range
'設定
Const PickUp As Integer = 4 'カウント数の下限
Range("D1").ClearContents
Range("E1:F1").CurrentRegion.ClearContents
Set rng = Range("A1", Range("A65536").End(xlUp).Offset(, 2))
'AdvancedFilterの前の条件をクリア
　Call DbNamesDelete
Application.ScreenUpdating = False
'並べ替え
rng.Sort Key1:=Range("A1"), _
　　　　　　　　Order1:=xlAscending, _
　　　　　　　　Header:=xlYes, _
　　　　　　　　OrderCustom:=1, _
　　　　　　　　MatchCase:=False, _
　　　　　　　　Orientation:=xlTopToBottom, _
　　　　　　　　SortMethod:=xlPinYin
'抽出1
　 rng.Resize(, 1).AdvancedFilter Action:=xlFilterCopy, _
　　　　　　　　　　　　　　　　　CopyToRange:=Range("E1"), _
　　　　　　　　　　　　　　　　　Unique:=True

Application.ScreenUpdating = True

Application.ScreenUpdating = False

'Pickupのカウント(以上）の抽出
With Range("E1", Range("E65536").End(xlUp))
　　rngValue = Range("E1", Range("E65536").End(xlUp)).Value
'Countifの代用
　 buf = 1
　　For i = LBound(rngValue, 1) + 1 To UBound(rngValue, 1)
　　rtn = Application.Match(rngValue(i, 1), rng.Resize(, 1), 1)
　　.Cells(i, 1).Offset(, 1).Value = rtn - buf
　　buf = rtn
　　Next i
　　'クライテリアの消去
　　Call DbNamesDelete
　　 Range("E1:F1").Value = Array(Range("A1").Value, "QTY")
　　 Range("H1:H2").Value = Application.Transpose(Array("QTY", ">=" & PickUp))
　　 If Range("E1").CurrentRegion.Rows.Count = 1 Then GoTo LineQuit
　　 .Resize(, 2).AdvancedFilter Action:=xlFilterInPlace, _
　　　　　　CriteriaRange:=Range("H1:H2"), _
　　　　　　Unique:=False
　　On Error Resume Next
　　 .SpecialCells(xlCellTypeVisible).Copy Range("K1")
　　On Error GoTo 0
　　 ActiveSheet.ShowAllData
　　 Range("E1").CurrentRegion.ClearContents
　　 Range("H1:H2").ClearContents
　End With
Application.ScreenUpdating = True

Application.ScreenUpdating = False
　'クライテリアの作成　'
　Range("K2", Range("K1").End(xlDown)).Offset(, 1).Formula = "=""<>""&RC[-1]&""?"""
　 Range("K2", Range("K1").End(xlDown)).Offset(, 1).Value = _
　　　 Range("K2", Range("K1").End(xlDown)).Offset(, 1).Value
　Set CriteriaRng = Range("K1", Range("K1").End(xlDown).Offset(, 1))
　Range("K1").Offset(, 1).Value = Range("K1").Value
Application.ScreenUpdating = True

Application.ScreenUpdating = False

　'抽出2
　Call DbNamesDelete
　 rng.AdvancedFilter Action:=xlFilterCopy, _
　　　　　　　　　　　CriteriaRange:=CriteriaRng, _
　　　　　　　　　　　CopyToRange:=Range("E1").Resize(, 3), _
　　　　　　　　　　　Unique:=False
LineQuit:
　CriteriaRng.ClearContents
Application.ScreenUpdating = True

Call DbNamesDelete
Set rng = Nothing: Set CriteriaRng = Nothing
End Sub
Sub DbNamesDelete()
Dim nm As Name
　'データベース関数の予約語を削除
　　For Each nm In ThisWorkbook.Names
　　If nm.Name Like "*[DatabaseCriteriaExtract]*" Then nm.Delete
　 Next
End Sub

お礼

う～、色々とありがとうございます！
けれど申し訳ありませんが、よく分かりません。
また１の回答の方の方法で、何とかなるようです。
ご面倒おかけしました！

回答No.2

Wendy02

VBAで作ってみました。
＞品名は1000以上、全ロット数は30000ほどあります。

ただ、１つ確認ですが、
＞４ロット以上の品名だけを

品名だけでよいのですか？
それが違うと、無駄になるので、確認してから、アップロードします。

それと、できれば、フィールド行が１つほしいところです。
(つまり、１行目を、A1:品名　　B1:ロットNo. C1:データ)

としていただきたいこと。そうしないと、数の計算を間違えることがあります。
フィルターオプション(AdvancedFilter)を使う理由からです。

なお、確認のために、数えた数を、品名の隣に出します。

例:

E列　　F列
品名　　数
a　　　40
b　　　25

計測時間は、私の古いパソコンで、品目1,000件、１つずつ調べて、30,000個のデータを、出力するのに、約2分20秒程度かかります。

補足

お世話様です。

＞品名だけでよいのですか？
誤解しやすい表現ですみませんでした。
品名だけであればピボットで簡単にできますね。

４ロット以上ある品名と、個々のロットのNo.とデータを抽出するのが目的です。逆に言うと、ロット数が３ロット以下の品名のデータを除外したいのです。
ですので、はじめの質問で記載した方法で実行すれば可能なのですが、それの処理速度を改善したいと考えています。

＞それと、できれば、フィールド行が１つほしいところです。
につきましては、問題ありません。実際にはフィールド行使用しています。

よろしくお願いします。