特定のセルに記入された回数分、他のシートに反映するには？

質問

特定のセルに記入された数字の数だけ、特定セルの値を別のシートに一括して反映させたいのです。
下記は以前にこちらのサイトで教えていただいたマクロ（記入シート内のA1,A4,A7,A10に記入した文字列を、
別シートのB列,L列,M列,N列に反映させるマクロ）です。
これを使用して、セルの値が10なら別シートに10列分反映させるようにしたいのですが・・・（値はその都度変わります）。
どなたかご教授いただける方がおられましたらよろしくお願いいたしますm(__)m

Sub ボタン1_Click()
　　Dim SourceRow As Integer
　　Dim DestCell As Range
　　Set DestCell = Worksheets("Sheet2").Range("B65535").End(xlUp)
　　　　If DestCell.Row = 1 And DestCell.Value <> "" Or DestCell.Row <> 1 Then
　　　　Set DestCell = DestCell.Offset(1, 0)
　　End If
　　With ActiveSheet
　　　　DestCell = .Range("A1")
　　　　DestCell.Offset(0, 11) = .Range("A4")
　　　　DestCell.Offset(0, 12) = .Range("A7")
　　　　DestCell.Offset(0, 13) = .Range("A10")
　　End With
End Sub

回答No.3

ham_kamo

さっそく修正してみました。
このマクロではB1のセルにコピーする行数が入っていると仮定しているので、１ヶ所だけ出てくるRange("B1")のところを実際のセル番地に書き換えてください。
このセルが空白や０以下の数値が入っていると、既定の動作として１行だけコピーしますが、数値以外の文字列が入っているとエラーとしてメッセージを出すようにしています。

Sub ボタン1_Click()
　　Dim DestRow As Integer
　　Dim CountCell As Range
　　Dim Count As Integer, i As Integer

　　Set CountCell = Range("B1")
　　If Not IsNumeric(CountCell.Value) Then
　　　　MsgBox "転記する数を数値で指定してください", vbExclamation, "入力エラー"
　　　　CountCell.Select
　　　　Exit Sub
　　End If

　　Count = CountCell.Value
　　If Count <= 0 Then
　　　　Count = 1
　　End If

　　With Worksheets("Sheet2")
　　　　DestRow = Application.WorksheetFunction.Max( _
　　　　　　.Range("B65535").End(xlUp).Row, _
　　　　　　.Range("M65535").End(xlUp).Row, _
　　　　　　.Range("N65535").End(xlUp).Row, _
　　　　　　.Range("O65535").End(xlUp).Row) + 1
　　　　For i = 0 To Count - 1
　　　　　　.Cells(DestRow + i, 2) = ActiveSheet.Range("A1")
　　　　　　.Cells(DestRow + i, 12) = ActiveSheet.Range("A4")
　　　　　　.Cells(DestRow + i, 13) = ActiveSheet.Range("A7")
　　　　　　.Cells(DestRow + i, 14) = ActiveSheet.Range("A10")
　　　　Next
　　End With
End Sub

お礼

ham_kamo様

返事が遅くなってしまい申し訳ありませんm(__)m
マクロはばっちり動作しました！！本当にありがとうございました。
これを気に本格的にマクロの勉強をしていこうと思います！！お世話になりましたm(__)m

回答No.2

ham_kamo

No.1です。補足拝見しました。

それで、繰り返しの動作についての質問があります。
「A1,A4,A7,A10に記入した文字列を、別シートのB列,L列,M列,N列に反映」
とありますが、たとえば10回ならA1,A4,A7,A10に入っている文字列を10行分転記する、つまり全部同じ内容になるということでいいのでしょうか。
それとも2行目からはB1,B4,B7,B10、3行目からはC1,C4,C7,C10というように転記する元の値もずれていくのでしょうか。

その点について補足をお願いいたします。

補足

ham_kamo様
>たとえば10回ならA1,A4,A7,A10に入っている文字列を10行分転記す
>る、つまり全部同じ内容になるということでいいのでしょうか。

上記でお願い致します。

回答No.1

ham_kamo

こんばんは。これは、
http://oshiete1.goo.ne.jp/kotaeru.php3?qid=2543890
のANo.3で私が回答したものですね。
補足を見て、このマクロでは不具合を起こす可能性があるので、修正した回答を書き込んだのですが（詳細は前の質問のANo.4をご覧ください）、とりあえずそちらの方で動作確認していただけないでしょうか？

ちなみに前回修正したものを、もう一度転記しておきます。こちらで同じように動作したら、それを元にセルに記入された数だけ反映させるように改造してみようと思います。

Sub ボタン1_Click()
　　Dim DestRow As Integer
　　With Worksheets("Sheet2")
　　　　DestRow = Application.WorksheetFunction.Max( _
　　　　　　.Range("B65535").End(xlUp).Row, _
　　　　　　.Range("M65535").End(xlUp).Row, _
　　　　　　.Range("N65535").End(xlUp).Row, _
　　　　　　.Range("O65535").End(xlUp).Row) + 1

　　　　.Cells(DestRow, 2) = ActiveSheet.Range("A1")
　　　　.Cells(DestRow, 12) = ActiveSheet.Range("A4")
　　　　.Cells(DestRow, 13) = ActiveSheet.Range("A7")
　　　　.Cells(DestRow, 14) = ActiveSheet.Range("A10")
　　End With
End Sub

補足

ham_kamo様

前回はありがとうございましたm(__)m　またまたお世話になってしまいそうで申し訳ないデス・・・。
せっかく修正したものを載せていただいたのに使用せずに申し訳ありませんでしたm(__)m
初めに記載していただいたマクロを使用したのは、その日にどうしても必要で時間がなかったためです。動作自体もあのマクロでまったく問題はないように見受けられました。（実際に使わせていただいていますが問題等でておりません。）　
修正していただいたマクロでも、まったく問題なく動作するのは確認済みです。
もしよろしければ修正していただたマクロで今回の質問にお答えいただけると助かります。どうぞよろしくお願いしますm(__)m