エクセルＶＢＡで表の合体をさせたい。

質問

エクセルにVBAってのがあると知って勉強を始めたばかりの者です。よろしくお願いいたします。
VBAで次のようなことをしたいのですが、いい方法が思いつきません。VBAに詳しい方教えて頂けないでしょうか？
シートが２枚あります。
１つのシートには、
A-101,　　,　　,あ1
A-102,　　,　　,
A-103,　　,　　,あ2
というデーターが書き込まれています。
２つ目のシートには、
A-101-1,　　,
A-101-2,　　,
A-101-3,　　,
A-102-1,　　,
A-102-2,　　,
A-103-1,　　,
A-103-2,　　,
A-103-3,　　,
A-103-4,　　,
と書き込まれています。
そこで、
A-101-1,　　,あ1
A-101-2,　　,あ1
A-101-3,　　,あ1
A-102-1,　　,
A-102-2,　　,
A-103-1,　　,あ2
A-103-2,　　,あ2
A-103-3,　　,あ2
A-103-4,　　,あ2
というふうに合体させたいのですが、いい方法ないでしょうか？
一つ目のループは、4列めのセルにデータが書き込まれているかを調べて書き込まれていたら、
1列目のセルの値が含まれる２枚目のシートのセルを全てループし、該当するものがあれば書き込むって
感じかなぁ？と思うのですが、実現には、単純にループを行う力業しかないのでしょうか？
いい案があれば、教えてください。宜しくお願いいたします。
","は、セルの区切りを表しているつもりです。

回答No.2

Wendy02 · ベストアンサー

こんにちは。

>エクセルにVBAってのがあると知って勉強を始めたばかりの者です。

もし、VBAの勉強でしたら、あまり、最初から、ワークシートの処理は手は出さないほうがよいです。なかなか、難しいです。オブジェクトという範囲が、はっきり見えないうちに手を出すと、何をやっているかわけが分からなくなります。純粋に、VBAの中での処理を目指したほうが、VBAの理解や上達は早いです。

ExcelのVBAは、Cells と Range, Sheet と Worksheet, Workbook と Window と、同じ範疇なのに、その扱いやその親(Parent)のオブジェクトの違うものが、交互に現れます。初級レベルの人が行うミスとしては、Rangeの中で、Cells を用いるときに、親オブジェクトを忘れるということです。だから、動く時とそうでなくエラーを出すときがあるのです。

かなりプログラミングを知っているつもりでも、Excel独特の癖を知っていないと、おかしなマクロを書いてしまいます。エラーを出すたびに少しずつ覚えるといっても過言ではないほど、とてもややこしいのです。

以下は、初級レベルと中級レベルのマクロの書いておきますので、少し、考えてみてください。
なお、Sheet1 のC 列のデータを Sheet2 のD列に写す、と読みましたので、もし違うようでしたら、マクロの中を直してください。

初級のポイントは、Like演算子を使いました。中級のポイントは、オートフィルタを使いました。初級と中級の差は、完成スピードの差として現れます。しかし、私たちが感知できるレベルでは、それほどは違わないはずです。

'基本的に標準モジュール
'------------------------------------------------

Sub TestValuesCopy()
　Dim Sh1 As Worksheet
　Dim Sh2 As Worksheet
　Dim i As Long
　Dim j As Long
　Dim LastRow1 As Long
　Dim LastRow2 As Long

　Set Sh1 = Worksheets("Sheet1")
　Set Sh2 = Worksheets("Sheet2")

　Application.ScreenUpdating = False
　LastRow1 = Sh1.Range("A65536").End(xlUp).Row 'シート1のA列-最後のセルを探す
　LastRow2 = Sh2.Range("A65536").End(xlUp).Row 'シート2のA列-最後のセルを探す

　For j = 1 To LastRow1
　　For i = 1 To LastRow2
　　　If Sh2.Cells(i, 1).Value Like Sh1.Cells(j, 1).Value & "-#*" Then
　　　'Like 演算子で比較します。# は、数字、* は、0回以上の何の文字も含む
　　　　Sh2.Cells(i, 1).Offset(0, 3).Value = Sh1.Cells(j, 1).Offset(0, 2).Value
　　　End If
　　Next i
　Next j
　Application.ScreenUpdating = True
　Set Sh2 = Nothing
　Set Sh1 = Nothing
End Sub

'----------------------------------------------------
Sub UpperLevelValuesCopy()
　Dim r1 As Range　'シート1のA1の範囲
　Dim c As Range

　Application.ScreenUpdating = False

　With Worksheets("Sheet1")
　　Set r1 = .Range("A1", .Range("A65536").End(xlUp))
　End With

　With Worksheets("Sheet2")
　　'ダミーのタイトル（オートフィルタ用のタイトル行)
　　If .AutoFilterMode = True Then
　　　.AutoFilterMode = False
　　Else
　　　.Range("A1").EntireRow.Insert
　　　.Range("A1").Value = "Nos"
　　End If
　　'オートフィルタを準備
　　With .Range("A1").CurrentRegion.Columns(1)
　　　For Each c In r1
　　　　If VarType(c.Value) = vbString And Not IsEmpty(c.Offset(, 2)) Then
　　　　'オートフィルタを使用する
　　　　　.AutoFilter Field:=1, Criteria1:=c.Value & "-*"
　　　　　.Offset(, 3).Value = c.Offset(, 2).Value
　　　　End If
　　　Next
　　End With
　　'オートフィルタを解除
　　.AutoFilterMode = False
　　.Range("A1").EntireRow.Delete
　End With
　Application.ScreenUpdating = True

　Set r1 = Nothing
End Sub

'----------------------------------------------------

お礼

ご丁寧に、２例もサンプルを提示していただき有難う御座います。
がんばって、教えて頂いた内容を活用していきたいと思います。

回答No.4

onlyrom

>実現には、単純にループを行う力業しかないのでしょうか？
>いい案があれば、教えてください。

ということからして「単純なループでの方法」は知っているから、
それ以外の方法を知りたいということですよね？
ですが、「勉強を始めたばかり」であれば基本であるその
「単純なループ」のコードをアップして、
それをベースに話しを進めた方がより勉強になると思いますが、
どうでしょう。

回答No.3

zap35

こんなマクロではどうでしょう。アルゴリズム大会になりそうですが…

Sub Matching()
Dim LastRow1, Lastrow2, idxR As Long, res
Dim Sheet1 As Worksheet
　Set Sheet1 = Worksheets("Sheet1")
　LastRow1 = Sheet1.Range("A65536").End(xlUp).Row
　With Worksheets("Sheet2")
　　Lastrow2 = .Range("A65536").End(xlUp).Row
　　For idxR = 1 To Lastrow2
　　　res = Application.Match(Left(.Cells(idxR, 1), 5), Range(Sheet1.Cells(1, 1), _
　　　　　Sheet1.Cells(LastRow1, 1)), 0)
　　　If IsNumeric(res) Then
　　　　.Cells(idxR, 3) = Sheet1.Cells(res, 4)
　　　End If
　　Next idxR
　End With
End Sub

マクロはALT＋F11でVBE画面を開き、「VBAProjectエクスプローラのシート名右クリック」→「挿入」→「標準モジュール」で表示される画面にペーストして下さい。実行はALT＋F8を押して、マクロ名を選択します。

回答No.1

TTak

二つ目のシートの３列目の１行目（ [C1] のセルかな）に、
=IF(INDEX(Sheet1!C$1:C$3,MATCH(LEFT(A1,5),Sheet1!A$1:A$3,))=0,"",INDEX(Sheet1!C$1:C$3,MATCH(LEFT(A1,5),Sheet1!A$1:A$3,)))
と入力します。
セルC1を選択した状態で、（選択セルは太枠で表示されていますね）
太枠の右下の■のとろにカーソルを合わせると、カーソルが＋に変わるので、そこでダブルクリックして、下方向にコピーします。

これをマクロで記録すればできあがりです。
ただ、この記録は行数が変わった時に対応できませんので、
例えば、A列の際下段が何段目か？を得るために、
Range(Cells(ActiveSheet.Rows.Count, 1) .End(xlUp).Address).Row
を用いても良いでしょう。"1"は列数です。
すなわち、このマクロにループは不要です。

VBAの勉強を始められたとのことですが、がんばってください(^^)