人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルで下記の動作をマクロで行って欲しいのですが
どのようなコードで作成すれば良いのでしょうか?
ポイントは実用的だった回答の方に配分します。

エクセルのBOOK AとBOOK Bがあります。
比較したい値は下記となっています。
BOOKA
worksheetA
セルA 番号A
セルD 番号B

BOOKB
worksheetA
セルE 番号B


BOOKBのセルEとBOOK AのセルDを比較して、同じ値なら
BOOKBのセルQにBOOKAの同列の番号Aを代入し、セルRに番号Aの数を
カウントし代入したい。
結果が複数の場合は、番号Aを「/」で区切りたい

例)
BOOK A
セルA セルD
1 123
2 224
3 123
4 555
5 455

BOOK B
セルE
100
123
214
224
318
455
500
515
555

----------------
マクロの結果

BOOK B
セルE セルQ セルR
100
123 1/3 2
214
224 2 1
318
455 5 1
500
515
555 4 1

●質問者: omoro
●カテゴリ:コンピュータ
✍キーワード:555 book エクセル カウント コード
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● Mook
●100ポイント ベストアンサー

一応仕様通りにしたつもりですが、異なる点がありましたらコメントにて対応しますので、

コメントを有効にお願いいたします。


処理毎に Q、R 列を初期化しますので、必要に応じてファイルを保存してください。

Sub CompAndCount()
 Dim refWS As Worksheet
 Set refWS = Workbooks("BOOKA.xls").Worksheets("Sheet1")
 
 Dim chkWS As Worksheet
 Set chkWS = Workbooks("BOOKB.xls").Worksheets("Sheet1")

 Dim r As Long
 Dim lastRow As Long
 lastRow = chkWS.Range("E" & Rows.Count).End(xlUp).Row
 
 chkWS.Columns("Q:R") = ""
 chkWS.Columns("Q:R").NumberFormatLocal = "@"
 
 
 Dim fr As Range
 Dim rr As Range
 For r = 2 To lastRow
 Set fr = refWS.Columns("D").Find(what:=chkWS.Cells(r, "E").Value, lookat:=xlWhole)
 If Not fr Is Nothing Then
 Set rr = fr
 Do
 If chkWS.Cells(r, "Q") = "" Then
 chkWS.Cells(r, "Q") = refWS.Cells(fr.Row, "A").Value
 chkWS.Cells(r, "R") = 1
 Else
 chkWS.Cells(r, "Q") = chkWS.Cells(r, "Q") & "/" & refWS.Cells(fr.Row, "A").Value
 chkWS.Cells(r, "R") = chkWS.Cells(r, "R") + 1
 End If
 Set fr = refWS.Columns("D").FindNext(fr)
 Loop While fr.Address <> rr.Address
 End If
 Next
End Sub
◎質問者からの返答

さっそくの回答ありがとうございます。

ほぼ期待動作通りなのですが、1行目だけ結果が

Q、Rに表示されないのですが、なぜでしょうか?


2 ● SALINGER
●50ポイント

こんな感じでどうでしょうか。

BOOKBとBOOKAを開いてどちらかの標準モジュールから実行してください。


Sub Macro()
 Dim wsA As Worksheet
 Dim wsB As Worksheet
 Dim lastRowA As Long
 Dim lastRowB As Long
 Dim i As Long
 Dim j As Long
 
 Set wsA = Workbooks("BOOKA.xls").Worksheets("worksheetA")
 Set wsB = Workbooks("BOOKB.xls").Worksheets("worksheetA")
 
 lastRowA = wsA.Cells(Rows.count, "A").End(xlUp).Row
 lastRowB = wsB.Cells(Rows.count, "E").End(xlUp).Row
 
 For i = 1 To lastRowB
 For j = 1 To lastRowA
 If wsB.Cells(i, "E").Value = wsA.Cells(j, "D").Value Then
 If wsB.Cells(i, "Q").Value = "" Then
 wsB.Cells(i, "Q").NumberFormatLocal = "@"
 wsB.Cells(i, "Q").Value = wsA.Cells(j, "A").Value
 Else
 wsB.Cells(i, "Q").Value = wsB.Cells(i, "Q").Value & "/" & wsA.Cells(j, "A").Value
 End If
 wsB.Cells(i, "R").Value = wsB.Cells(i, "R").Value + 1
 End If
 Next j
 Next i
End Sub
◎質問者からの返答

さっそくの回答ありがとうございます。

「wsB.Cells(i, "R").Value = wsB.Cells(i, "R").Value + 1」

で型が一致しません

とエラーが出てしまいました。。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ