エクセルvba 指定シートの指定位置に貼り付け

画像のように、A列のシート名の、B列の値と一致する場所に、C列の値を貼り付けるというマクロを作りたいです。シートごとに貼り付けるとこまでは自力でできたのですがB列の値を見てC列の値を貼り付けるところで息づまってしまいました。
ご教示いただきたいです。

一応自力で作成したものを貼り付けます。
※シート名の指定は特定の文字が含まれてたら、という設定にしてます。
　（実際に使うときにこの方が都合がいいため。）

Sub Macro1()

Dim i As Long
Dim n As Long
Dim m As Long
Dim MaxRow As Long

MaxRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
n = 1
m = 1


For i = 1 To MaxRow


If InStr(Sheets("Sheet1").Cells(i, 1).Value, "野菜") <> 0 Then

Sheets("野菜").Cells(n, 2).Value = Sheets("Sheet1").Cells(i, 3).Value
n = n + 1

ElseIf InStr(Sheets("Sheet1").Cells(i, 1).Value, "果物") <> 0 Then

Sheets("果物").Cells(m, 2).Value = Sheets("Sheet1").Cells(i, 3).Value
m = m + 1
End If

Next

End Sub

質問者からの補足コメント

• わかりにくくてすみません。説明が難しかったので果物や野菜や数値に例えましたが、実際はsheet1のB列に同じ項目があってもA列のシート名が違うので、貼り付け先である各シートのB列に値が入ってることはありません。なので、GooUserラックさんのいう、「常に上書き」で大丈夫です。

  No.1の回答に寄せられた補足コメントです。 補足日時：2017/02/07 14:33

No.1 回答者： GooUserラック 回答日時： 2017/02/07 13:43

「C列の値を貼り付ける」は常に上書きで良いのですか？

「C列の値に加算して、元の値をクリアする、または元のＤ列あたりに加算済みしるしをつける」の方が実用的だと思うのですがいかがでしょうか？

No.2 ベストアンサー 回答者： GooUserラック 回答日時： 2017/02/07 14:46

それではこのようなものはいかがでしょうか？

----------------------------------------------------------------------------
Sub Macro()
Dim 行 As Long
With Sheets("Sheet1")
For 行 = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
If .Cells(行, 4).Value <> "加算済" Then
If InStr(.Cells(行, 1).Value, "野菜") <> 0 Then
Call シート処理("野菜", .Cells(行, 2).Value, .Cells(行, 3).Value)
End If
If InStr(.Cells(行, 1).Value, "果物") <> 0 Then
Call シート処理("果物", .Cells(行, 2).Value, .Cells(行, 3).Value)
End If
End If
Next
End With
End Sub

Sub シート処理(シート名 As String, 品名 As String, 値 As Variant)
Dim 行 As Long
With Sheets(シート名)
For 行 = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
If .Cells(行, 1).Value = 品名 Then
.Cells(行, 2).Value = 値
Exit Sub
End If
Next
.Cells(行, 1).Value = 品名
.Cells(行, 2).Value = 値
End With
End Sub
----------------------------------------------------------------------------

※① 品名追加が簡単に行えるように処理を分けてみました。以下を必要なだけ追加すれば良い。
----------------------------------------------------------------------------
If InStr(.Cells(行, 1).Value, "○○") <> 0 Then
　Call シート処理("○○", .Cells(行, 2).Value, .Cells(行, 3).Value)
End If
----------------------------------------------------------------------------

※② 品名がなかったときは追加します。不要でしたら次の２行を削除して下さい。
----------------------------------------------------------------------------
.Cells(行, 1).Value = 品名
.Cells(行, 2).Value = 値
----------------------------------------------------------------------------

この回答へのお礼

やりかたっかたことが実現できました！本当にありがとうございます助かりました。

お礼日時：2017/02/07 16:09