vba 記述をスマートにしたい

質問

お世話になります。
以下の記述をもっと簡略化させたいのですが、
列とシートが違うだけで、同じ処理を２回しているだけなので、
出来そうで、自分では出来ませんでした。
どなたかご教示頂きたく宜しくお願い致します。

　　　　　　記
Set myrngv = Workbooks("Ａ.xls").Sheets("sheet1").Range("a:a")
Set myrngYK = Workbooks("Ａ.xls").Sheets("sheet1").Range("t:t")
Set myrialz = Workbooks("Ａ.xls").Sheets("sheet2").Range("b:b")
Set myXBrialz = Workbooks("Ａ.xls").Sheets("sheet3").Range("b:b")

j = 3
Do
j = j + 1
myhin = myrngv.Cells(j, 1).Value
If myhin = "" Then Exit Do

Set c = myrialz.Find(what:=myhin, Lookat:=xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address

Do
myrow = c.Row

myrngv.Cells(j, 9) = myrialz.Cells(myrow, 7).Value
myrngv.Cells(j, 11) = myrialz.Cells(myrow, 8).Value
myrngv.Cells(j, 13) = myrialz.Cells(myrow, 3).Value
myrngv.Cells(j, 5) = myrialz.Cells(myrow, 3).Value + Cells(myrow, 7).Value - Cells(myrow, 8).Value

Set c = myrialz.FindNext(c)

Loop Until firstaddress = c.Address

End If
Loop

'ここより下が同じ様な処理
j = 3
Do
j = j + 1
myhin = myrngYK.Cells(j, 1).Value
If myhin = "" Then Exit Do

Set c = myXBrialz.Find(what:=myhin, Lookat:=xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address

Do
myrow = c.Row

myrngYK.Cells(j, 8) = myXBrialz.Cells(myrow, 7).Value
myrngYK.Cells(j, 10) = myXBrialz.Cells(myrow, 8).Value
myrngYK.Cells(j, 12) = myXBrialz.Cells(myrow, 3).Value
myrngYK.Cells(j, 6) = myXBrialz.Cells(myrow, 3).Value + Cells(myrow, 7).Value - Cells(myrow, 8).Value

Set c = myXBrialz.FindNext(c)

Loop Until firstaddress = c.Address

End If
Loop

回答No.1

redfox63 · ベストアンサー

この2つのルーチンでどこが違って どこが似たよう物なのかを考えましょう

myrngvとmyrngYKが転記先のセル
myrialzとmyXBrialzが転記元のセルおよび検索対象
転記先のセル番地が異なっている
とこの3つの用件を満たせば サブルーチン(プロシージャ)化が出来そうです

転記先セル、転記元セルは Rangeオブジェクトで受ければよさそうで
異なるセル番地は 配列でその番地を与えればいいでしょう

Sub TransferMacro( rTrg as range, rSrc as Range, nRows()as integer)
　　dim j as Integer, myRow as Long
　　dim c as Range, myhin as String, firstaddress as String
　　j = 3
　　Do
　　　　j = j + 1
　　　　myhin = rTrg.Cells(j, 1).Value
　　　　If myhin = "" Then Exit Do

　　　　Set c = rSrc.Find(what:=myhin, Lookat:=xlWhole)
　　　　If Not c Is Nothing Then
　　　　　　firstaddress = c.Address
　　　　　　Do
　　　　　　　　myrow = c.Row
　　　　　　　　rTrg.Cells(j, nRows(0)) = rSrc.Cells(myrow, 7).Value
　　　　　　　　rTrg.Cells(j, nRows(1)) = rSrc.Cells(myrow, 8).Value
　　　　　　　　rTrg.Cells(j, nRows(2)) = rSrc.Cells(myrow, 3).Value
　　　　　　　　' 右辺のCells(myrow, 7).Value,Cells(myrow, 8).Valueが
　　　　　　　　' アクティブシートのセルを使うのでしたら
　　　　　　　　' 『rSrc.』を消してください …
　　　　　　　　rTrg.Cells(j, nRows(3)) = rSrc.Cells(myrow, 3).Value + _
　　　　　　　　　　rSrc.Cells(myrow, 7).Value - rSrc.Cells(myrow, 8).Value

　　　　　　　　Set c = rSrc.FindNext(c)
　　　　　　Loop Until firstaddress = c.Address
　　　　End If
　　Loop
End Sub
といった具合で呼び出し元を

dim nRows(3)
nRows(0) = 9
nRows(1) = 11
nRows(2) = 13
nRows(3) = 5
TransferMacro myrngv, myrialz, nRows
nRows(0) = 8
nRows(1) = 10
nRows(2) = 12
nRows(3) = 6
TransferMacro myrngYK, myXBrialz, nRows
といった具合でしょう
# 字下げに全角スペースを使用しています 適宜置換してください

お礼

ありがとうございます。
大変参考になりました。