列の値と一致するシートを選び、指定セルをコピぺする

質問

マクロの勉強をしている初心者です。

タイトルにありますように、あらかじめ列に入力する値と一致するシートを検索し、そのシートの中の所定の場所にあるセルの値をひろう、というマクロをつくりたいのですがご教示頂けないでしょうか。

わかりづらいので例を画像を添付します。
（手書きですみません。）

まず、左のbookと右のbookは別であり、右は読み込み用で、左bookに入力をしていくものです。
左bookの売上げ（赤塗）、目標（青塗）という部分に、右bookのというセルの場所の値をコピペすることを希望です。

毎回人の入れ替わりが頻繁にあるため、Aと同じ値のシートを選ばせるというところからプログラムさせたいです。左bookは上から田中、山下、と並んでいますが、その都度何行目に誰がくるかはかわります。
右bookのコピーしたいセルの場所（B列6行目、C列6行目)はどのシートも変わりません。

恐れ入りますがご教示の程宜しくお願いします。

回答No.2

kkkkkm · ベストアンサー

> 右bookのコピーしたいセルの場所（B列6行目、C列6行目)はどのシートも変わりません。

として、以下で試してみてください。ブック名やシート名は実際のものに変更してください。画像の矢印は右向きですが左向きではないでしょうか…。

Sub Test()
Dim Ws1 As Worksheet, Wb1 As Workbook, Sh As Worksheet
Dim mstr As String
Dim LastRow As Long, i As Long, flg As Boolean

Set Ws1 = ThisWorkbook.Worksheets("Sheet1") '左Bookのシート名
Set Wb1 = Workbooks("右book.xlsx")

LastRow = Ws1.Cells(Rows.Count, "A").End(xlUp).Row
mstr = ""
For i = 2 To LastRow
flg = False
For Each Sh In Wb1.Worksheets
If Sh.Name = Ws1.Cells(i, "A").Value Then
Ws1.Cells(i, "B").Value = Sh.Cells(6, "B").Value
Ws1.Cells(i, "D").Value = Sh.Cells(6, "C").Value
flg = True
Exit For
End If
Next
If flg = False Then
mstr = mstr & Ws1.Cells(i, "A").Value & " : "
End If
Next
If mstr <> "" Then
MsgBox mstr & "シートがありません", vbCritical
End If
Set Ws1 = Nothing
Set Wb1 = Nothing
End Sub

お礼

初心者にわかりやすい変数でくみあわされており、正しい数字を簡単に取得することができました！本当ありがとうございます！
あまりに勉強する内容が多い為、一旦答えを頂いた後にそれぞれの変数がどのような意味を示すか、ひとつひとつ調べるやり方をしています。助かりました。

回答No.6

imogasi

こんなのは、基礎的な知識として、オブジェクトを「掴む」方法について
（１）シート場合　シートの名前を指定して、（下記注と関連する）（VBAで）で捕まえられる
（２）セル　名前を定義済みのセルでなければ、行、列の捕捉を頼りに
　　　　　　特定せざるええない。
　　　　　　隣に、そのセル場所を特定する文字列があれば、それを頼って使える場合がある。
こう言うことを、質問者は、はっきり意識してない段階なだけで、こういう質問になるのでは？
他人には、面白みのない課題だろう。
＝＝＝
例データ　Sheet1 A1:B4
- 売上
田中
山下
山田
個別シートには
田中、山下、山田のシートがあり、シートタブの名前順はどうでもよい(注）。
名前の各シートの
A6:B6　　には
田中では　合計 160000
山下では　合計 300000
山田では　合計 190000
が入っているとする。
Ｂ列で「合計」という文字列で合計行を探すことにする。
ーーー
標準モジュールに
Sub test01()
With Worksheets("Sheet1")
lr = .Cells(1000, "A").End(xlUp).Row
MsgBox lr
For Each cl In .Range("A2:A" & lr)
MsgBox cl.Value
Set sh = Worksheets(cl.Value)
r = sh.Range("A:A").Find("合計").Row
MsgBox r
.Cells(cl.Row, "B") = sh.Cells(r, "B")
Next
End With
End Sub
ーーー
実行すると、結果Sheet1
売上
田中 160000
山下 300000
山田 190000
＝＝＝
個人的な行き掛かり上Withを使ったが,
使わずに
Sub test21()
Set sh1 = Worksheets("Sheet1") '集約シート
lr = sh1.Cells(1000, "A").End(xlUp).Row
MsgBox lr
For i = 2 To lr

Set sh2 = Worksheets(sh1.Cells(i, "A").Value)
r = sh2.Range("A:A").Find("合計").Row
MsgBox r
sh1.Cells(i, "B") = sh2.Cells(r, "B")
Next
End Sub
の方がすっきりしているかな。
＝＝＝
別構想として、こういうことを考える癖を付けないと、今後のため、進歩しないのでは。
本質問では、名前のリストがSheet1のA列にあると（前提に）したが、
名前シートの、あるがままの順にSheeｔ1に集約データを作り、名前（Ａ列）の
順序をソート（ただし、ユーザーリストを作ってのソート）する方法もある。
ちょっと凝っている方法かも。何を言っているか判る？

お礼

ありがとうございます。頂いたプログラムで例の通りのシートを作成し、やってみましたところ、求めている数字をつくりあげることができました。

あとは、各項目がなんの意味をするのか？ネットと本で調べていきます。前回助言頂いたように、本を常備するようにいたします。

意味を理解することで、応用できるようになりますのでがんばりますね！

回答No.5

kkkkkm

No2を左book以外で実行する場合は

Set Ws1 = ThisWorkbook.Worksheets("Sheet1") '左Bookのシート名

を

Set Ws1 = Workbooks("左book.xlsm").Worksheets("Sheet1") '左Bookのシート名

に変更してください。左book.xlsmは実際のブック名。

回答No.4

kkkkkm

No2の追加です。

> 右bookのコピーしたいセルの場所（B列6行目、C列6行目)はどのシートも変わりません。

これが、常時6行目固定という意味ではなく、月ごとに行は変化するが全てのシートの合計の行が同じ行であるという意味でしたら

Dim TRow As Long

を宣言の所に追加して

LastRow = Ws1.Cells(Rows.Count, "A").End(xlUp).Row
の前に
TRow = Wb1.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row
を追加して

Ws1.Cells(i, "B").Value = Sh.Cells(6, "B").Value
Ws1.Cells(i, "D").Value = Sh.Cells(6, "C").Value

の2か所を

Ws1.Cells(i, "B").Value = Sh.Cells(TRow, "B").Value
Ws1.Cells(i, "D").Value = Sh.Cells(TRow, "C").Value

に変更してください。
ただし、右bookの一番左のシートが質問の画像のようなフォーマットのシートでB列の合計行より下に何もない(式も含めて)ことが前提です。
合計行より下に何かあるのでしたらA列の合計という文字のセルを探すという処理にする必要があります。

回答No.3

kkkkkm

No2は左bookで実行してください。
また、A列の途中に空白がある場合は

If flg = False Then

を

If flg = False And Ws1.Cells(i, "A").Value <> "" Then

に変更してください。

回答No.1

HohoPapa

添付画像の構造を前提に
後記コードを標準モジュールに配置し、
値を取得したいセルに
=GetJisseki($A2,B$1)
といった計算式を埋める解はいかがでしょうか。

なお、右側ブックのA1セルに"年月"を埋める必要があります。
また、右側ブックの6行目を見つけているのではなく
"年月"列の"合計"の行を拾う仕様です。
つまり、必ずしも6行目である必要はありません。

Function GetJisseki(StaffName As String, ColName As String) As Double
Dim SQL As String
Dim cn As Object
Dim rs As Object
Const JisBook = "C:\test\実績.xlsx"

'SQL全文を組み立て
SQL = "SELECT [" & ColName & "]" & vbCrLf
SQL = SQL & "FROM [" & StaffName & "$A1:Z50000]" & vbCrLf
SQL = SQL & "Where [年月] = '合計'" & vbCrLf

'SQLを実行
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
cn.Open JisBook
rs.Open SQL, cn
GetJisseki = rs(ColName)

'後処理
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

End Function

お礼

ありがとうございました！レベルをあげて回答頂き感謝です。要求する数字をひろうことができました。私の知識が不足しており、わからない言葉だらけなので、一つ一つ調べてその仕組みを理解していきたいと思います。