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

質問

エクセルマクロ　繰り返して、別のシートへコピーしたい
マクロ初心者のため、やり方が全くわかりません。
どなたか教えてください。
やりたいことは、
コピーするシートはあらかじめ作成しています。
簡素化の方法がわからないので、
とりあえず自分で作ってみたものが下にあるものです。

繰り返す方法がわからないので、

どなたか教えてください。
よろしくお願いします。

以下、作成したマクロです。
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

回答No.6

Wendy02 · ベストアンサー

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

お礼

一応、下記のようにして使用できそうです。
処理の早さはさすがに早かったです。
RIGHTBやLEFTBもチャレンジしてみたいとおもいます。

Sub TransferTest1_ST()
Dim n As Long
Dim myData(24) As Variant 'myDataも24
Dim rng As Range
Dim c As Variant
Dim i As Long, j As Long, k As Long
'最初のrng の部分を決めてくれれば良いです。ただし、隣り合うセルは、{：}でつなぎます。
Set rng = Worksheets("Sheet1").Range("A5,A5,B5,B6,D5,E5,F5,F7,G5,G7,H5,H7,L5,L7,M5,N5,O5,P5,Q5,S5,S6,S7,S8,T6")
'myDataもResizeも24にする↑24個あるから

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("B2").Offset(k).Resize(, 24).Value = myData() 'Resizeも24
Erase myData()
k = k + 1

Next j
Set rng = Nothing
End Sub

補足

ありがとうございます。
配列は苦手ですが、
処理時間は、早くなりそうな気がするので、
本当は、配列を使った方がよい気がします。
シンプルで短いソースがいいなぁと
作成していくうちに、思うようになりました。
時間はかかるかもしれませんが、
こちらも使って、作ってみたいとおもいます。

レスのつけ方が、いまいちですみません。

回答No.7

noname#130090

#3です。

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

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

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

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

お礼

気長くお付き合ってくださって、
本当にありがとうございました。

回答No.5

noname#130090

配列が空っぽになってしまう...なんでしょう。
僕の範囲指定が間違っていたようです。

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

これで有無を言わさず回転するのではないでしょうか？
ソースもかなり単純ですので間違ってても
簡単に書き直せると思われますがどうですか？

お礼

ありがとうございました。

補足

ありがとうございます。
返信の遅くなってすみません。

RIGHTBやLEFTBもチャレンジしていたので
少し時間がかかってしまいました。

下記の様に書き直して実行してみました。
一応動いたのですが、
突然、ものすごく遅くなってしまったので、
つまづいてしまっていました。
解決は、ツールのオプションの再計算を手動にするにチェックで解決しました。

Sub sheet2をsheet1にコピーする。()
' sheet2をsheet1にコピーする。
Dim i As Long

''Dim TEL1(0 To 600) As Variant

Dim WS1 As Worksheet
Set WS1 = Worksheets(1) '("Sheet1")'' Sheets("Sheet1").Select

WS1.Select
For i = 0 To 600 '10人なら9とする。
With Sheets("sheet2")
.Range("B" & 1 + i) = Range("A" & 5 + (i * 4))
.Range("C" & 1 + i) = Range("A" & 5 + (i * 4))
.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))
.Range("K" & 1 + i) = Range("G" & 7 + (i * 4))
.Range("L" & 1 + i) = Range("H" & 5 + (i * 4))
.Range("M" & 1 + i) = StrConv(RightB(StrConv(WS1.Range("H" & 5 + (i * 4)), vbFromUnicode), 13), vbUnicode)
' .Range("M" & 1 + i) = Range("H" & 5 + (i * 4)) '=RIGHTB(Sheet1!$H$5,$B$3)

.Range("N" & 1 + i) = Range("H" & 7 + (i * 4))
.Range("O" & 1 + i) = StrConv(RightB(StrConv(WS1.Range("H" & 7 + (i * 4)), vbFromUnicode), 13), vbUnicode)
' .Range("O" & 1 + i) = Range("H" & 7 + (i * 4)) '=RIGHTB(Sheet1!$H$7,$B$3)

.Range("P" & 1 + i) = StrConv(RightB(StrConv(WS1.Range("T" & 6 + (i * 4)), vbFromUnicode), 13), vbUnicode)
' .Range("P" & 1 + i) = Range("T" & 6 + (i * 4)) '=RIGHTB(Sheet1!$T$6,$B$3)
.Range("Q" & 1 + i) = StrConv(LeftB(StrConv(WS1.Range("T" & 6 + (i * 4)), vbFromUnicode), 3), vbUnicode)
' .Range("Q" & 1 + i) = Range("T" & 6 + (i * 4)) '=LEFTB(Sheet1!$T$6,3)

.Range("R" & 1 + i) = Range("L" & 5 + (i * 4))
.Range("S" & 1 + i) = Range("L" & 7 + (i * 4))
.Range("T" & 1 + i) = Range("M" & 5 + (i * 4))
.Range("U" & 1 + i) = Range("N" & 5 + (i * 4))
.Range("V" & 1 + i) = Range("N" & 7 + (i * 4))
.Range("W" & 1 + i) = Range("O" & 5 + (i * 4))
.Range("X" & 1 + i) = Range("P" & 5 + (i * 4))
.Range("Y" & 1 + i) = Range("Q" & 5 + (i * 4))
.Range("Z" & 1 + i) = Range("R" & 5 + (i * 4))
.Range("AA" & 1 + i) = Range("R" & 7 + (i * 4))
.Range("AB" & 1 + i) = Range("S" & 7 + (i * 4))
.Range("AC" & 1 + i) = Range("S" & 8 + (i * 4))
.Range("AD" & 1 + i) = Range("S" & 6 + (i * 4))
End With
Next i
Sheets("Sheet2").Select
End Sub

回答No.4

noname#130090

#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

お礼

ありがとうございます。
一応emptyは下記の方法で解決しました。

Sub test3()
Dim hairetsu(1 To 7) As Variant, i As Long
Sheets("Sheet1").Select
Do While Range("B14").Offset(i * 4) <> ""

' Sheets("Sheet1").Select
hairetsu(1) = Range("B14").Offset(i * 4) ' '
hairetsu(2) = Range("B14").Offset(i * 4 + 1) 'B15
hairetsu(3) = Range("B14").Offset(i * 4, 1) 'D14
hairetsu(4) = Range("B14").Offset(i * 4, 2) 'E14
hairetsu(5) = Range("B14").Offset(i * 4, 3) 'F14
hairetsu(6) = Range("B14").Offset(i * 4, 4) 'G14
hairetsu(7) = Range("B14").Offset(i * 4 + 2, 3) 'F16
Sheets("sheet2").Range("D1:J1").Offset(i) = hairetsu
i = i + 1 'これがなかったので無限ループになっていました
Loop
Sheets("Sheet2").Select
End Sub

補足

ありがとうございます。
Sub test()を実行して
ものすごく感動してしまいましたが、

結合されているためか、
二回目のloopで
hairetsuに入っている値が
emptyになってしまいます。（汗）
配列って難しいですね。
悪戦苦闘中。

回答No.3

noname#130090

もう回答が必要でない場合はスルーしてくださればと思います。
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の数で対応できるのでは？
繰り返しの種類は
適宜使いやすく処理の軽い（速い）ものを選べばいいのではないかと思います。

お礼

処理の軽いというのは、大事ですね。
やはり配列大事と思いました。
ありがとうございました。

回答No.2

Wendy02

こんばんは。

ご質問のコードには無駄なのか間違いなのか、ともかく、どのようにするか、言葉で書いていただいたほうがよいのではありませんか？

・シート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　この部分は、値と書式をコピーしているものだとは思いますが、一回ごとにコピーしなければならないほど複雑なものなのでしょうか？

お礼

質問を文章にする難しさを痛感させられました。
＞・シート1 のB14:C14　をシート2 のA1:B1 にコピー&ペーストします。
＞・シート1 のB15:C17　をシート2 のB1:C3 にコピー&ペーストします。
＞(そうすると、C14 の部分がB1で上書きされてしまいます。)
結合されているセルをコピーして値だけ貼り付けた場合、
C14の部分は値がはいっていないので、上書きされてもOKです。

＞それと、PasteSpecial Paste:=xlPasteValuesAndNumberFormats　
＞この部分は、値と書式をコピーしているものだとは思いますが、
＞一回ごとにコピーしなければならないほど複雑なものなのでしょうか？
手動で動作を行ったら、
生年月日等の日付は、値を貼り付けたら、シリアル値で出てしまうし、
年齢の所は、セルの書式設定の表示形式のユーザー定義で文字を入れたりしてるので、
値と書式をコピーしないとうまくいかなかったのです。
新しいマクロを作成させて、
つくったものでしたので、不必要なものがたくさんできていたように
思います。

回答No.1

mt2008

貼り付けるシート名がどう言う規則になっているのか判りませんでしたので、とりあえず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

お礼

適切でない補足を載せてしまってすみません。
繰り返し処理の理解が深まるきっかけを与えて下さって
ありがとうございました。
今回は、貼り付けるシートはひとつでしたので、
繰り返し処理の所を応用して、
シートではなく行に変えてやっていきました。

複数のシートに同じデータをコピーする場合に、
参考にさせて頂きたいと思います。

補足

説明がヘタですみません。
シートは、二つしかありません。（Sheet1とSheet2）
それをSheet1の行がなくなるまで、繰り返す。

Sheet1にある一行目のデータ（列の結合をされている。）
Sheet1!$B$5
Sheet1!$B$6
Sheet1!$D$5
Sheet1!$E$5
Sheet1!$F$5
Sheet1!$G$5
Sheet1!$F$7
このデータを
Sheet2の一行目から
D1
E1
F1
G1
H1
I1
J1
に貼り付けたい。
貼り付ける場合（計算式をいれているので、形式を選択して値と値の書式を貼り付ける）

Sheet1にある二行目のデータ（列の結合をされている。）
繰り返しで、行い、増える数字を変数にしたい。+4みたく。

Sheet1!$B$9
Sheet1!$B$10
Sheet1!$D$9
Sheet1!$E$9
Sheet1!$F$9
Sheet1!$G$9
Sheet1!$F$11
このデータを
Sheet2の二行目から
繰り返しで、行い、増える数字を変数にしたい。+1みたく。
D2
E2
F2
G2
H2
I2
J2
に貼り付けたい。
貼り付ける場合（計算式をいれているので、形式を選択して値と値の書式を貼り付ける）

ちなみに、繰り返し処理の命令に、
下記のを使うのと、For　～　Next　をつかうのと
どちらがよいでしょうか。

Do Until ??.Value　=　""　'行が終わるまで。
繰り返すコピーアンド貼り付け処理。
Loop
Set ?? = Nothing