VBAでの構成抽出(重複の削除/カウント)

前提・実現したいこと

以前もこちらでお世話になりました。
ありがとうございます。

またわからない問題が発生してしまったのでまた利用させていただきます。

++++++++++++++++++++++++

現在とある製品を作る際に必要な材料構成数を調べようとしています。

製品A→ネジA/ネジB/板版100A etc...

構成は変更になる場合があるため、生産実績から抽出してくるため
製品A　ネジA
・
・
製品A　ネジA
と重複している可能性があります。

そのため

①生産実績から必要項目をコピー
②製品コードと材料コードを&で結び、重複を削除した後に製品コードを親にして
材料構成を":"で一つのセルに表示
③:の数をカウントして構成を抽出

という手間をかけようとしています。
出力するとこんな感じです↓↓

|　　A　　 | B | C | D | E |
|製品コード|類別コード|親コード(Aと同じ)|構成A：構成B...|構成数|

違うシートに製品コードの一覧があるので、そこにD列(構成内容)とE列(構成数)を参照するために複雑な手順を踏んでいます。。。

重複が上手く作動していないことが問題なのですが、もう少し簡単な集計方法がございましたら教えてください。

VBA
1Sub 材料構成調査()
2
3'================================　必要な部分のみ抽出します
4
5Dim SH1 As Worksheet, SH2 As Worksheet
6
7    Set SH1 = Worksheets("①抽出結果")
8    Set SH2 = Worksheets("材料構成")
9            
10    SH2.Select
11    
12    SH1.Range("A1").CurrentRegion.AdvancedFilter _
13    Action:=xlFilterCopy, copytorange:=Range("A1:B1")
14    
15'================================　重複の削除
16
17    Dim n As Long
18    n = Cells(Rows.Count, 2).End(xlUp).Row
19    Range("C2:C" & n).FormulaArray = "=A2:A" & n & "&""&""&B2:B" & n & "&"""""
20
21    UsedRange.RemoveDuplicates Columns:=(3), Header:=xlYes
22  
23    Columns("C").Delete
24
25'================================　構成数カウント
26
27  Dim lastRow As Long
28'準備
29   lastRow = Cells(Rows.Count, "A").End(xlUp).Row
30  Range("A:B").Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes
31  Range("C:C").Insert Shift:=xlShiftToRight
32  Range("C2:C" & lastRow).Formula = "=IF(A1=A2,C1&"":"","""")&B2"
33
34'コード抽出
35   Range("E:F").Insert Shift:=xlShiftToRight
36  Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("E1"), unique:=True
37
38'結果転記
39   lastRow = Cells(Rows.Count, "E").End(xlUp).Row
40  With Range("F2:F" & lastRow)
41  .Formula = "=VLOOKUP(E2,A:C,3)"
42  .Value = .Value
43  End With
44  Range("C:C").Delete Shift:=xlShiftToLeft
45
46End Sub
47
48

発生している問題・エラーメッセージ

   UsedRange.RemoveDuplicates Columns:=(3), Header:=xlYes

ここが黄色くなります。

試したこと

マクロの記録からどうにかやろうとしましたが限界です。。。
また、VBAでのINDEXMATCHもやりかたがわからず、構成数がわかっても製品一覧にデータが貼り付けられないため、関数で行っていますので、そちらもわかりましたらよろしくお願いします。。。。

追記＊
構成数は月によって変わってしまうのが見えないためこのような手段をとっています。
同じ製品Aで1月は5構成、2月が10構成だと恐らく多いほうの構成で見えてしまうとは思いますが、おおよその構成を見たい(構成がどの程度かみたい)とのことなのでそこは大丈夫です。

mattuwan

2019/02/09 05:26

も少しコードの表も含めて、回答側でも動作確認ができるようなサンプルデータを提示してみてはいかがでしょう？

行動規範の内容に同意します

回答2件

まず元データを加工するマクロを追加しました。

VBA
1'------材料コードを出力します(構成用)
2    
3    Dim j As Long
4    Dim zai As String, rui As String
5    Columns(12).Insert
6    
7    For j = 2 To lastrow
8        zai = Cells(j, "K")
9        rui = Cells(j, "D")
10        Cells(j, "L") = Range("K" & j).Value & Range("D" & j).Value
11    Next j
12    
13    Range("L1").Value = "材料コード"
14

そして↓のコードでリストを作成しました。

VBA
1
2Sub 材料構成数抽出()
3
4
5Application.ScreenUpdating = False
6Application.Calculation = xlCalculationManual
7
8'================================　必要な部分のみ抽出します
9
10    Dim Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet
11
12    Set Sh1 = Worksheets("抽出元データ")
13    Set Sh2 = Worksheets("材料構成")
14
15'------Sh2に計算フォームの見出しをあらかじめ=で結んでいます
16
17    Sh2.Select
18 
19    Sh1.Range("A1").CurrentRegion.AdvancedFilter _
20    Action:=xlFilterCopy, copytorange:=Range("A1:B1")
21    
22'------最終行の取得
23       
24    Dim r As Range
25    Dim lastrow As Long
26'準備
27    lastrow = Cells(Rows.Count, "A").End(xlUp).Row
28    Range("A2:A" & lastrow).Select
29    
30    
31'------材料コードの重複削除
32    
33    Range("A:B").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
34    
35
36'------最終行の取得
37       
38    Dim lastrowA, lastrowD As Long
39'準備
40    lastrowA = Cells(Rows.Count, "A").End(xlUp).Row
41    lastrowD = Cells(Rows.Count, "D").End(xlUp).Row
42    
43'------構成カウント
44    Dim v As Variant
45    Dim w As Variant
46    Dim dicD As Object
47    Dim dicR As Object
48    Dim d As Variant
49    Dim x As Long
50
51    Set dicD = CreateObject("Scripting.Dictionary")
52    Set dicR = CreateObject("Scripting.Dictionary")
53
54    w = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
55    ReDim v(1 To UBound(w, 1), 1 To 1)
56
57    For x = 1 To UBound(w, 1)
58        dicD(w(x, 1)) = dicD(w(x, 1)) + 1
59        If Not dicR.exists(w(x, 1)) Then dicR(w(x, 1)) = x
60    Next
61
62    For Each d In dicR
63        v(dicR(d), 1) = dicD(d)
64    Next
65
66    Range("C1").Resize(UBound(v, 1)).Value = v
67
68 
69 '------材料コードの重複削除
70    
71    Range("A:C").RemoveDuplicates Columns:=Array(1), Header:=xlYes
72    
73    Range("C1").Value = "構成数"
74 
75 
76 End Sub

おそらく手間をかけているので精査できるかもしれませんが、力不足のためこのコードでリスト作成することにしました。
回答ありがとうございました。

投稿2019/02/19 00:39

lq_hm_165912

総合スコア18

ベストアンサー

エラーメッセージを明記されていないので、外していたら申し訳ございませんがおそらくこれではないですか？

---------------------------
Microsoft Visual Basic for Applications
---------------------------
コンパイル エラー:

変数が定義されていません。
---------------------------
OK   ヘルプ   
---------------------------

UsedRangeプロパティはシートオブジェクトを省略することが出来ません。

従ってこのように記載すれば、コンパイルエラーは消えると思いますよ。

vba
1SH2.UsedRange.RemoveDuplicates Columns:=(3), Header:=xlYes

あとCellsもColumnsもRangeもシートオブジェクトは省略可能ですが、バグの元となりやすいので（特に2つ以上のシートを扱うときは）省略しないことをおすすめします。

中身はじっくり読んでいないので、意図したとおりに動くかどうかは分かりませんが、一度ご確認下さい。

2019/2/14追記

当初の回答については見当違いのようでした。

UsedRangeが使えないのは標準モジュールの場合で、コンパイルエラーではないとのことなので、シートモジュールに記載されているものと考えます。

エラー「配列の一部を変更することは出来ません」に関してですが、配列数式が入っているもの思われます。

プログラム上で配列数式を設定しているのは次のコードだけですが、他には心当たりはありませんか？

Range("C2:C" & n).FormulaArray = "=A2:A" & n & "&""&""&B2:B" & n & "&"""""

この直後を見るとColumns("C").Deleteとしているので、完全に重複削除のためだけに生成した式だと見受けられます。

C列だけだと仮定して、考えられる対処法は２つ

配列数式を値に置き換えてしまう。

例えばこんな感じです。

vba
1    Range("C2:C" & n).FormulaArray = "=A2:A" & n & "&""&""&B2:B" & n & "&"""""
2
3    Range("C2:C" & n).Value = Range("C2:C" & n).Value
4
5    UsedRange.RemoveDuplicates Columns:=(3), Header:=xlYes