マクロでシートからシートへの数式をいれるには？

Question

シート（別紙明細）
https://gyazo.com/3a8d8278d856f495e3906a005775ad4c
シート（別紙　明細　計）
https://gyazo.com/ae06ffbc40fd737e292d28f08778b97b

画像の表題ですが。
シートからシートへの処理がわかりません。
教えて下さい。

前提条件
①エクセル表の5行目～11760行目までくりかえすマクロを組みます
②一項目三行で形成されている表です
③シート（別紙　明細　計）にシート（別紙　明細）の項目が反映されるように数式を入れたい
④数式　　＝別紙明細!G(7,i)となるのでしょうか？
⑤別紙01計は別紙01へ　別紙02計は別紙02へ　と順番に自動化がしたい
⑥別紙　明細　計ｼｰﾄ　数式をいれる場所は別紙～と書かれている左となりの中段の行です
⑦別紙明細ｼｰﾄのそれぞれの別紙合計値は別紙（変数ｈ）の次の別紙（変数ｈ+1）のセルから見て一つ左の列の上に見ていき最初の数字が合計値です。

Sub 別紙から別紙へ()
Dim i As Long

For i = 5 To 11760
　　　　　　　　　　’5から11760まで
If　Range(i,8).Value = "別紙（　変数ｈ　）" Then
　　　　　　　　　　’別紙（　変数ｈ　）　文字があったら
　　Range(1+i,7).Value = "(=別紙明細!G(7,変数ｋ)"
　　　　　　　　　　’(=別紙明細!G(7,ｋ)数式をいれる
Next
End Sub

tatsumaru77 · Accepted Answer

No11です。補足ありがとうございました。以下のマクロを標準モジュールに登録してください。 Option Explicit Public Sub 別紙明細計設定() Dim sh1 As Worksheet Dim sh2 As Worksheet Dim dicT As Object Dim row1 As Long Dim row2 As Long Dim key_row As Long Dim maxrow1 As Long Dim maxrow2 As Long Dim maxrowh As Long Dim key As String Set sh1 = Worksheets("別紙明細　計") Set sh2 = Worksheets("別紙明細") Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義 maxrow2 = sh2.Cells(Rows.Count, "B").End(xlUp).row 'B列の最大行取得 maxrowh = sh2.Cells(Rows.Count, "H").End(xlUp).row 'H列の最大行取得 If maxrowh > maxrow2 Then maxrow2 = maxrowh '別紙XXの計の次の行を全て記憶する key = "" For row2 = 5 To maxrow2 If Left(sh2.Cells(row2, "H").Value, 2) = "別紙" Then If key <> "" Then sh2.Activate sh2.Cells(row2, "H").Select MsgBox ("別紙連続エラー[" & sh2.Cells(row2, "H").Value & "]") Exit Sub End If key = sh2.Cells(row2, "H").Value key_row = row2 Else If sh2.Cells(row2, "B").Value = "計" Then If key = "" Then sh2.Activate sh2.Cells(row2, "B").Select MsgBox ("計連続エラー") Exit Sub End If dicT(key) = row2 + 1 key = "" End If End If Next If key <> "" Then sh2.Activate sh2.Cells(key_row, "H").Select MsgBox ("別紙に計なし[" & key & "]") Exit Sub End If maxrow1 = sh1.Cells(Rows.Count, "H").End(xlUp).row 'H列の最大行取得 For row1 = 5 To maxrow1 If Left(sh1.Cells(row1, "H").Value, 2) = "別紙" Then key = sh1.Cells(row1, "H").Value If dicT.Exists(key) = False Then sh1.Activate sh1.Cells(row1, "H").Select MsgBox ("[" & key & "]は別紙明細に存在しません") Exit Sub End If sh1.Cells(row1 + 1, "G").Formula = "=別紙明細!" & sh2.Cells(dicT(key), "G").Address(False, False) End If Next MsgBox ("完了") End Sub

めぐみん_ · Answer

でもAutofilterの方が速いのかも？

めぐみん_ · Answer

No.13です。

ちょっとミスです。（老眼ジジィなので）
後半の

Set rh2 = .Range("H5", .Cells(Rows.Count, "H")).Find("別紙", .Cells(Rows.Count, "H"), xlValues, xlPart)

If rh1 Is Nothing Then '←★
MsgBox "該当なしにつき終了"

↓

Set rh2 = .Range("H5", .Cells(Rows.Count, "H")).Find("別紙", .Cells(Rows.Count, "H"), xlValues, xlPart)

If rh2 Is Nothing Then '←★　変数名を間違えてて気づかず
MsgBox "該当なしにつき終了"

めぐみん_ · Answer

双方のシートの『別紙　n』が一致しており、且つ同じ番号の場合同じ計算式を入れても良ければ、

Sub megu_Rev()
Dim myDic As Object
Dim rb1 As Range, rh1 As Range
Dim rh2 As Range
Dim stAD As String
Const stF As String = "=別紙明細!"

Set myDic = CreateObject("Scripting.Dictionary")

With Worksheets("別紙明細")

Set rh1 = .Range("H5", .Cells(Rows.Count, "H")).Find("別紙", .Cells(Rows.Count, "H"), xlValues, xlPart)

If rh1 Is Nothing Then
MsgBox "該当なしにつき終了"
Exit Sub
End If

stAD = rh1.Address

Do

Set rb1 = .Range("B5", .Cells(Rows.Count, "B")).Find("計", .Cells(rh1.Row, "B"), xlValues, xlWhole)

If Not rb1 Is Nothing Then
If Not myDic.Exists(rh1.Value) Then myDic.Add rh1.Value, stF & rb1.Offset(1, 5).Address(0, 0)
Else
Exit Do
End If

Set rh1 = .Range("H5", .Cells(Rows.Count, "H")).Find("別紙", .Cells(rb1.Row, "H"), xlValues, xlPart)

Loop Until rh1.Address = stAD

End With

With Worksheets("別紙明細　計") 'スペースは環境にもよるので念のためそちらで打ち直してください

Set rh2 = .Range("H5", .Cells(Rows.Count, "H")).Find("別紙", .Cells(Rows.Count, "H"), xlValues, xlPart)

If rh1 Is Nothing Then
MsgBox "該当なしにつき終了"
Exit Sub
End If

stAD = rh2.Address

Do

If myDic.Exists(rh2.Value) Then
rh2.Offset(1, -1).Formula = myDic(rh2.Value)
Else
rh2.Offset(1, -1).Value = "該当なし"
End If

Set rh2 = .Range("H5", .Cells(Rows.Count, "H")).Find("別紙", rh2, xlValues, xlPart)

Loop Until rh2.Address = stAD

End With

End Sub

－－－－－－－－－

ジジィなので歩み（処理速度）は亀に勝てるかどうか・・・

めぐみん_ · Answer

お～ベテラン様が引き継いで下されるようなので、過去の回答コードとは違う手段で作成したものは必要ないですね。
⇒と言うより最初からこっちで作れば良かったと思う所が初級レベルなジジィですよねぇ。

tatsumaru77 · Answer

補足要求です。
＞『別紙明細』ｼｰﾄの『備考』H列に別紙01とあれば、それ以下の行で初めに出てくる計が別紙01の合計値になるので、
＞それを『別紙明細　計』の別紙01とあるセルの一つ下の行のＧ列に数値が反映されるようにするのが目的です。

１．『別紙明細』シートの別紙と計の並びは、以下のようになるということですが、
このように並ばない場合は、エラーとしますが宜しいでしょうか。
H列　別紙XX
B列　計
H列　別紙YY
B列　計

例１
H列　別紙XX
H列　別紙YY
B列　計
のように 別紙が連続して並んだ場合

例２
H列　別紙XX
B列　計
B列　計
のように 計が連続して並んだ場合

例１、例２の場合はエラーとなります。

２．『別紙明細　計』シートの別紙　XXが　『別紙明細』シートにない場合は、エラーとしますが宜しいでしょうか。
又、以下のような場合もエラーとなります。
『別紙明細　計』シート　「別紙△△01」
『別紙明細』シート　　　「別紙□01」
△は１つの半角スペース
□は１つの全角スペースとします。
上記の場合、みためは、同じように見えますが、別のものとして扱われますが、よろしいでしょうか。
又、01についても、片方が半角の01、他方が全角の０１のような場合も、別のものとして扱われますが、よろしいでしょうか。

３．上記の１，２でエラーが発生した場合は、処理を打ち切りますが、よろしいでしょうか。

めぐみん_ · Answer

すなわち

＞それを『別紙明細　計』の別紙01とあるセルの一つ下の行のＧ列に数値が反映されるようにするのが目的です。

って『別紙n』はコードで作成するのではなく既に『別紙明細　計』に存在しているって事になりますよね。
手入力で行なうのかはわかりませんが相当な遠回りなのですけど・・・・
ジジィは疲れましたよ。

先のベテラン様にまたお任せになりそう。

めぐみん_ · Answer

No.8の補足に対して。

＞コード起動すると、画像の様になり。
＞別紙　01　は表示されたのですが、別紙02～先が表示されなくて。

画像を見ても表示されているのですが？？？
あと『別紙詳細　計』シートのＢ列は『棚ｘ』１つに対して『計』１つになるのではなく、『計』が『棚ｘ』の位置にくる？（３行組の一番左上）
３行で１つの表を構成しているのですよね？
そこも変わったのですか？
そもそもＢ列に空欄（Ｂ５から２行開けて続くはず）もどうなっているのかさっぱりです。
シートの構成仕様が読み取れないので『どこにどんなデータがあってどのデータに対してどんな処理をするのかが不明確』な気がします。
何故Ｂ５～Ｂ１３が空白なのか？とか。
書き込むのはＢ５からですよね？

めぐみん_ · Answer

〇囲い数字を用いているようですが、画像のように似た物が存在しそれぞれは違いますので『検索しても見つからない』となる場合があります。
実際使用されているかはわかりませんが、そう言った似た記号的な物をお使いならば避けた方が宜しいかもです。

めぐみん_ · Answer

No.６です。

こちらのコードミスにつきましては、

Sub megu_ReTry2()
Dim r1 As Range, rs As Range, re As Range
Dim r2 As Range
Dim st As String, cnt As Long

Set r2 = Worksheets("別紙　明細　計").Range("B5")
cnt = 1

With Worksheets("別紙明細")

Set r1 = .Range("B5", .Cells(Rows.Count, "B").End(xlUp).Resize(3))

Do

Set rs = r1.Find(What:=r2.Value, After:=r1.Cells(r1.Rows.Count), LookIn:=xlValues, LookAt:=xlPart)

If Not rs Is Nothing Then

st = rs.Address

Do

Set re = r1.Find(What:="計", After:=rs, LookIn:=xlValues, LookAt:=xlWhole)

If Not re Is Nothing Then
With r2.Offset(1, 5)
.Formula = "=別紙明細!" & re.Offset(1, 5).Address(0, 0)
.NumberFormat = re.Offset(1, 5).NumberFormat
End With
r2.Offset(, 6).Value = Format(cnt, "別紙　00"): cnt = cnt + 1
Set r2 = r2.Offset(3)
If r2.Value = "" Then Exit Do
Set rs = r1.Find(What:=r2.Value, After:=re, LookIn:=xlValues, LookAt:=xlPart)
Else
Exit Do
End If

Loop Until rs.Address = st

Else
Set r2 = r2.Offset(3)
End If

Loop Until r2.Value = ""
End With

End Sub

これでいける感じはしますが、

＞If Not rs Is Nothing Thenがデバッグで黄色く変わりましたが

が最初のコードで出たのは検索値（別紙　明細　計シートのＢ列の値）が検索する範囲（別紙明細シートのＢ列）で見つけられなかった時ですね。
見つからなかった際の配慮が抜けてはいましたが、そもそも見つからない事は想定の範囲内でしょうか？
仮に全て見つかるはずと言うなら入力ミスや無駄な空白スペース（見えないですし）があるのかもですけど、確か前回の質問・回答でもベテラン様とやり取りしてませんでしたか？（記憶違いならすいません）

マクロでシートからシートへの数式をいれるには？

No11です。

でもAutofilterの方が速いのかも？

No.13です。

双方のシートの『別紙 n』が一致しており、且つ同じ番号の場合同じ計算式を入れても良ければ、

お～ベテラン様が引き継いで下されるようなので、過去の回答コードとは違う手段で作成したものは必要ないですね。

補足要求です。

すなわち

No.8の補足に対して。

〇囲い数字を用いているようですが、画像のように似た物が存在しそれぞれは違いますので『検索しても見つからない』となる場合があります。

No.６です。

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

双方のシートの『別紙　n』が一致しており、且つ同じ番号の場合同じ計算式を入れても良ければ、