エクセルVBA：選択・貼付け（繰り返し？）

質問

３種類の数式を、条件により選択しながら、不特定の回数（行数）に貼り付けたいのですが、どのようなコードが考えられますでしょうか？よろしくお願いします。

○Sheet1
　数式保存セル　数式(1)：AZ8　数式(2)：BA8　数式(3)：BB8

　数式選択条件　Ｄ列の値が (1)であれば数式(1)を、(2)であれば数式(2)を、(3)であれば数式(3)を

　数式適用範囲　I8 ～ AW107

　※３種類の数式はそれぞれ、I8 で作成し、保存セルにコピーして用意したもの

　例　／　D8 が(1)であれば、AZ8 をコピーして、I8 ～ AW8 に計算結果のみ貼付けたい（数式のみ→値のみ）
　　　　　D9 が(1)であれば、AZ8 をコピーして、I9 ～ AW9 に　　 〃
　　　　　D10 が(3)であれば、BB8 をコピーして、I10 ～ AW10 に　　〃
　　　　　D11 が(2)であれば、BA8 をコピーして、I11 ～ AW11 に　　〃
　　　　　・・・

　※何行使用するかは毎回変わる　　　※他シートを用意したくない
　※ AY列は空いている（行数をカウントし変数とする、IF関数を用い条件に応じて数式保存セル位置を文字列で表示し変数とする、などを組合わせてできないかと思いましたが、思い浮かびませんでした。）

回答No.4

noname#29107 · ベストアンサー

＃１です。
＞具体的なD列の値は、数式順に　背筋、アーム、レッグ　の三種類のみ
であれば、以下のように修正。

Sub test()
ix = 8
Do While Cells(ix, "D") <> ""
　　Select Case Trim(Cells(ix, "D"))
　　Case "背筋"
　　　　Range("AZ8").Copy Destination:=Range(Cells(ix, "I"), Cells(ix, "AW"))
　　Case "アーム"
　　　　Range("BA8").Copy Destination:=Range(Cells(ix, "I"), Cells(ix, "AW"))
　　Case "レッグ"
　　　　Range("BB8").Copy Destination:=Range(Cells(ix, "I"), Cells(ix, "AW"))
　　End Select
　　Range(Cells(ix, "I"), Cells(ix, "AW")).Copy
　　Cells(ix, "I").PasteSpecial Paste:=xlPasteValues
　　ix = ix + 1
Loop
Range("I8").Select
End Sub

何カ所か修正したのでそのままコピー貼り付けしてください。

お礼

ありがとうございました。すべて希望通りとなりました。感謝感激です。コードを短く書くというレベルではないものですから、理解するのに時間がかかりました。

補足

度々ありがとうございます。ほぼ希望通りです。質問が曖昧で申し訳ございません。貼り付けられるセルが色つきなものですから、書式も変えたくないのですが、最後のPasteの前のどこを調整すれば良いでしょうか。

回答No.3

noname#29107

＞Ｄ列の値が漢字やカタカナなのですが、
＃１です。具体的なD列の値はどんなのでしょう。
数値の項目はないのでしょうか？途中に空欄が入ることはないですか？
これだけの情報では、適当に修正してくださいとしか言えないです・・・・

Sub test()
ix = 8
Do While Cells(ix, "D") <> ""
　　Select Case Cells(ix, "D")
　　Case "1番目のD列の値" 'ここを修正
　　　　Range(Cells(ix, "I"), Cells(ix, "AW")).Formula = Range("AZ8").Formula
　　Case "2番目のD列の値" 'ここを修正
　　　　Range(Cells(ix, "I"), Cells(ix, "AW")).Formula = Range("BA8").Formula
　　Case "3番目のD列の値" 'ここを修正
　　　　Range(Cells(ix, "I"), Cells(ix, "AW")).Formula = Range("BB8").Formula
　　End Select
　　Range(Cells(ix, "I"), Cells(ix, "AW")).Copy
　　Cells(ix, "I").PasteSpecial Paste:=xlPasteValues
　　ix = ix + 1
Loop
End Sub

お礼

たびたびありがとうございます。空欄についてですが、ありました。Ｄ列の値が　背筋　の時のみE列が空欄になります。失礼いたしました。

補足

申し訳ございません。たいへん失礼いたしました。具体的なD列の値は、数式順に　背筋、アーム、レッグ　の三種類のみです。途中に空欄はありません。よろしくお願いします。

回答No.2

hana-hana3

Sub 式設定()

Dim line As Long

line = 9

Do

If Range("D" & line) = "(1)" Then
Range("I" & line).Formula = Range("AZ8").Formula
ElseIf Range("D" & line) = "(2)2" Then
Range("I" & line).Formula = Range("BA8").Formula
ElseIf Range("D" & line) = "(3)" Then
Range("I" & line).Formula = Range("BB8").Formula
ElseIf Range("D" & line) = "" Then
Exit Do
Else
Range("I" & line & ":AW" & line).Clear
End If

Range("I" & line & ":AW" & line) = Range("I" & line)

line = line + 1

Loop

End Sub

補足

ありがとうございます。素晴らしいと思ったものの、私の力不足で、成功しませんでした。実はＤ列の値が漢字やカタカナなのですが、そのせいでしょうか？

回答No.1

noname#29107

一例としてはこんな感じでしょうか。
Sub test()
ix = 8
Do While Cells(ix, "D") <> ""
　　Select Case Cells(ix, "D")
　　Case 1
　　　　Range(Cells(ix, "I"), Cells(ix, "AW")).Formula = Range("AZ8").Formula
　　Case 2
　　　　Range(Cells(ix, "I"), Cells(ix, "AW")).Formula = Range("BA8").Formula
　　Case 3
　　　　Range(Cells(ix, "I"), Cells(ix, "AW")).Formula = Range("BB8").Formula
　　End Select
　　Range(Cells(ix, "I"), Cells(ix, "AW")).Copy
　　Cells(ix, "I").PasteSpecial Paste:=xlPasteValues
　　ix = ix + 1
Loop
End Sub
途中にD列が空白になってもデータが107行まで続くなら、For ～nextで回すように変更したらいいでしょう。

補足

ご回答ありがとうございます。質問に漏れがあって、Ｄ列の値が漢字やカタカナなのですが、そのせいかうまくいきませんでした。基本を理解できていなく、申し訳ございません。お手数ですがご指導ください。