エクセルマクロ　繰り返して、別のシートへコピーしたい

Question

エクセルマクロ　繰り返して、別のシートへコピーしたい
マクロ初心者のため、やり方が全くわかりません。
どなたか教えてください。
やりたいことは、
コピーするシートはあらかじめ作成しています。
簡素化の方法がわからないので、
とりあえず自分で作ってみたものが下にあるものです。

繰り返す方法がわからないので、

どなたか教えてください。
よろしくお願いします。

以下、作成したマクロです。
1行目から１０行目まで繰り返したくて、
1行目から2行目のセルの移動の差は１０行目までかわりません。

'1行目
    Sheets("Sheet1").Select
    Range("B14:C14").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    
    Sheets("Sheet1").Select
    Range("B15:C17").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet2").Select
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    
 '2行目
    Sheets("Sheet1").Select
    Range("B18:C18").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    
    Sheets("Sheet1").Select
    Range("B19:C21").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet2").Select
    Range("B2").Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False

Wendy02 · Accepted Answer

2の回答者です。

私の問いに関しては、質問者さんは、完全無視のままのようですが、このままでは格好がつかないので、分かっている範囲で回答して置きます。私は、質問中途で質問が変わるご質問には、基本的には回答しない建前としていますし、ご質問者さんが、画像をアップしているのを知らなかったので、回答がちぐはぐになってしまったことは否定出来ません。今回、初めての質問のようでしたが、レスをつけようがつけまいが構いませんが、そのままにせずに、締めるようにしてください。

あえて、配列変数を使う理由などはありませんが、配列を生かすように作ってみました。コピー元の場所変更は可能ですが、書くときは、順序として隣り合ったセルの場合、必ず、コロン(：）でつなぐのがコツです。
'-------------------------------------------
Sub TransferTest1()
　　Dim myData(6) As Variant
　　Dim rng As Range
　　Dim c As Variant
　　Dim i As Long, j As Long, k As Long
　　'最初のrng の部分を決めてくれれば良いです。ただし、隣り合うセルは、{：}でつなぎます。
　　Set rng = Worksheets("Sheet1").Range("B11:B12,D11:G11,F12")
　　
　　For j = 0 To Cells(Rows.Count, 2).End(xlUp).Row Step 4　'4行置き
　　　　i = 0
　　　　For Each c In rng.Offset(j).Cells
　　　　　　myData(i) = c.Value
　　　　　　i = i + 1
　　　　Next c
　　　　Worksheets("Sheet2").Range("D2").Offset(k).Resize(, 7).Value = myData()
　　　　Erase myData()
　　　　k = k + 1
　　Next j
　　Set rng = Nothing
End Sub

noname#130090 · Answer

#3です。

転記の項目数が増えましたか？（笑
やはりひとつずつ転記よりも一旦配列に避難して
その後、一括表示させたほうが速そうに感じます。

それと600回転させるよりも、何か指標を決めて
途中で止めてしまうほうがいいようにも感じます。

例えばfor文の途中で
　　if Range("A" & 5 + (i * 4)) = "" then exit for
を入れておくというような。

当初の「エクセルマクロ　繰り返して、別のシートへコピーしたい」
は達成できているようですので私はこれでコメントを終了します。
では、頑張ってください。

noname#130090 · Answer

配列が空っぽになってしまう...なんでしょう。
僕の範囲指定が間違っていたようです。

Sub test()
　　Dim i As Long
　　Sheets("Sheet1").Select
　　For i = 0 To 9
　　　　with Sheets("sheet2")
　　　　　　.Range("D" & 1 + i) = Range("B" & 5 + (i * 4))
　　　　　　.Range("E" & 1 + i) = Range("B" & 6 + (i * 4))
　　　　　　.Range("F" & 1 + i) = Range("D" & 5 + (i * 4))
　　　　　　.Range("G" & 1 + i) = Range("E" & 5 + (i * 4))
　　　　　　.Range("H" & 1 + i) = Range("F" & 5 + (i * 4))
　　　　　　.Range("I" & 1 + i) = Range("G" & 5 + (i * 4))
　　　　　　.Range("J" & 1 + i) = Range("F" & 7 + (i * 4))
　　　　end with
　　Next i
　　Sheets("Sheet2").Select
End Sub

これで有無を言わさず回転するのではないでしょうか？
ソースもかなり単純ですので間違ってても
簡単に書き直せると思われますがどうですか？

noname#130090 · Answer

#3です（汗
無限ループになってしまっていました。
前述のVBAは動かすと止まらないので「Escキー」を押して逃げてください。

Sub test()
　　Dim hairetsu(1 To 7) As Variant, i As Long
　　Sheets("Sheet1").Select
　　Do While Range("F11").Offset(i * 4) <> ""
　　　　hairetsu(1) = Range("B9").Offset(i * 4)
　　　　hairetsu(2) = Range("B10").Offset(i * 4)
　　　　hairetsu(3) = Range("D9").Offset(i * 4)
　　　　hairetsu(4) = Range("E9").Offset(i * 4)
　　　　hairetsu(5) = Range("F9").Offset(i * 4)
　　　　hairetsu(6) = Range("G9").Offset(i * 4)
　　　　hairetsu(7) = Range("F11").Offset(i * 4)
　　　　Sheets("sheet2").Range("D1:J1").Offset(i) = hairetsu
　　　　i = i + 1 　　'これがなかったので無限ループになっていました
　　Loop
　　Sheets("Sheet2").Select
End Sub

noname#130090 · Answer

もう回答が必要でない場合はスルーしてくださればと思います。
For以外にもこんな方法もありますよということで。


Sub test()
　　Dim hairetsu(1 To 7) As Variant, i As Long
　　Sheets("Sheet1").Select
　　Do While Range("F11").Offset(i * 4) <> ""
　　　　hairetsu(1) = Range("B9").Offset(i * 4)
　　　　hairetsu(2) = Range("B10").Offset(i * 4)
　　　　hairetsu(3) = Range("D9").Offset(i * 4)
　　　　hairetsu(4) = Range("E9").Offset(i * 4)
　　　　hairetsu(5) = Range("F9").Offset(i * 4)
　　　　hairetsu(6) = Range("G9").Offset(i * 4)
　　　　hairetsu(7) = Range("F11").Offset(i * 4)
　　　　Sheets("sheet2").Range("D1:J1").Offset(i) = hairetsu
　　Loop
　　Sheets("Sheet2").Select
End Sub


7つの配列とLoop文でやってあります。
これなら配列の数とRangeの数で対応できるのでは？
繰り返しの種類は
適宜使いやすく処理の軽い（速い）ものを選べばいいのではないかと思います。

Wendy02 · Answer

こんばんは。

ご質問のコードには無駄なのか間違いなのか、ともかく、どのようにするか、言葉で書いていただいたほうがよいのではありませんか？

・シート1 のB14:C14　をシート2 のA1:B1 にコピー&ペーストします。
・シート1 のB15:C17　をシート2 のB1:C3 にコピー&ペーストします。

(そうすると、C14 の部分がB1で上書きされてしまいます。)

次に
・シート1 のB18:C18　をシート2 のA2:B2 にコピー&ペーストします。
・シート1 のB19:C21　をシート2 のB2:C4 にコピー&ペーストします。
(そうすると、C18 の部分がB2　と、C18 の部分がB2:C2で上書きされてしまいます。)

それと、PasteSpecial Paste:=xlPasteValuesAndNumberFormats　この部分は、値と書式をコピーしているものだとは思いますが、一回ごとにコピーしなければならないほど複雑なものなのでしょうか？

mt2008 · Answer

貼り付けるシート名がどう言う規則になっているのか判りませんでしたので、とりあえずSheet2～Sheet10までを対象としたサンプルを提示します。

あまり良いコードでは有りませんが、勉強の取っ掛かりになれば幸いです。
データのコピー＆ペースト部は質問に有ったマクロの一部だけを入れて居ます。


Sub Sample()

　Dim sPasteSheet As String
　Dim i
　For i = 2 To 10 'Sheet2～Sheet10が対象の場合(ループ開始）
　　sPasteSheet = "Sheet" & i   '貼り付け先シート名        
    
　　Sheets("Sheet1").Select
　　Range("B14:C14").Select
　　Application.CutCopyMode = False
　　Selection.Copy
　　Sheets(sPasteSheet).Select  '貼り付けシート選択
　　Range("A1").Select
　　Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= xlNone, SkipBlanks:=False, Transpose:=False

　Next i  '(ループ終了）
End Sub

エクセルマクロ 繰り返して、別のシートへコピーしたい

2の回答者です。

この回答への補足

#3です。

配列が空っぽになってしまう...なんでしょう。

この回答への補足

#3です（汗

この回答への補足

もう回答が必要でない場合はスルーしてくださればと思います。

こんばんは。

貼り付けるシート名がどう言う規則になっているのか判りませんでしたので、とりあえずSheet2～Sheet10までを対象としたサンプルを提示します。

この回答への補足

似たような質問が見つかりました

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

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

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

エクセルマクロ　繰り返して、別のシートへコピーしたい