エクセルマクロ 繰り返して、別のシートへコピーしたい
マクロ初心者のため、やり方が全くわかりません。
どなたか教えてください。
やりたいことは、
コピーするシートはあらかじめ作成しています。
簡素化の方法がわからないので、
とりあえず自分で作ってみたものが下にあるものです。
繰り返す方法がわからないので、
どなたか教えてください。
よろしくお願いします。
以下、作成したマクロです。
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
投稿日時 - 2010-02-09 16:32:06
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
投稿日時 - 2010-02-17 00:29:45
補足
ありがとうございます。
配列は苦手ですが、
処理時間は、早くなりそうな気がするので、
本当は、配列を使った方がよい気がします。
シンプルで短いソースがいいなぁと
作成していくうちに、思うようになりました。
時間はかかるかもしれませんが、
こちらも使って、作ってみたいとおもいます。
レスのつけ方が、いまいちですみません。
投稿日時 - 2010-02-22 10:45:56
お礼
一応、下記のようにして使用できそうです。
処理の早さはさすがに早かったです。
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
投稿日時 - 2010-02-22 13:53:18
3人が「このQ&Aが役に立った」と投票しています
ベストアンサー以外の回答（6件中 1～5件目)
#3です。
転記の項目数が増えましたか？（笑
やはりひとつずつ転記よりも一旦配列に避難して
その後、一括表示させたほうが速そうに感じます。
それと600回転させるよりも、何か指標を決めて
途中で止めてしまうほうがいいようにも感じます。
例えばfor文の途中で
if Range("A" & 5 + (i * 4)) = "" then exit for
を入れておくというような。
当初の「エクセルマクロ 繰り返して、別のシートへコピーしたい」
は達成できているようですので私はこれでコメントを終了します。
では、頑張ってください。
投稿日時 - 2010-02-22 15:55:08
お礼
気長くお付き合ってくださって、
本当にありがとうございました。
投稿日時 - 2010-02-22 16:06:32
配列が空っぽになってしまう...なんでしょう。
僕の範囲指定が間違っていたようです。
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
これで有無を言わさず回転するのではないでしょうか？
ソースもかなり単純ですので間違ってても
簡単に書き直せると思われますがどうですか？
投稿日時 - 2010-02-12 17:18:02
補足
ありがとうございます。
返信の遅くなってすみません。
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
投稿日時 - 2010-02-22 10:40:02
お礼
ありがとうございました。
投稿日時 - 2010-02-22 16:26:29
#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
投稿日時 - 2010-02-11 07:54:50
補足
ありがとうございます。
Sub test()を実行して
ものすごく感動してしまいましたが、
結合されているためか、
二回目のloopで
hairetsuに入っている値が
emptyになってしまいます。（汗）
配列って難しいですね。
悪戦苦闘中。
投稿日時 - 2010-02-12 15:11:30
お礼
ありがとうございます。
一応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
投稿日時 - 2010-02-12 17:21:05
もう回答が必要でない場合はスルーしてくださればと思います。
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の数で対応できるのでは？
繰り返しの種類は
適宜使いやすく処理の軽い（速い）ものを選べばいいのではないかと思います。
投稿日時 - 2010-02-11 07:49:31
お礼
処理の軽いというのは、大事ですね。
やはり配列大事と思いました。
ありがとうございました。
投稿日時 - 2010-02-22 16:29:37
こんばんは。
ご質問のコードには無駄なのか間違いなのか、ともかく、どのようにするか、言葉で書いていただいたほうがよいのではありませんか？
・シート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 この部分は、値と書式をコピーしているものだとは思いますが、一回ごとにコピーしなければならないほど複雑なものなのでしょうか？
投稿日時 - 2010-02-09 21:47:56
お礼
質問を文章にする難しさを痛感させられました。
＞・シート1 のB14:C14 をシート2 のA1:B1 にコピー&ペーストします。
＞・シート1 のB15:C17 をシート2 のB1:C3 にコピー&ペーストします。
＞(そうすると、C14 の部分がB1で上書きされてしまいます。)
結合されているセルをコピーして値だけ貼り付けた場合、
C14の部分は値がはいっていないので、上書きされてもOKです。
＞それと、PasteSpecial Paste:=xlPasteValuesAndNumberFormats
＞この部分は、値と書式をコピーしているものだとは思いますが、
＞一回ごとにコピーしなければならないほど複雑なものなのでしょうか？
手動で動作を行ったら、
生年月日等の日付は、値を貼り付けたら、シリアル値で出てしまうし、
年齢の所は、セルの書式設定の表示形式のユーザー定義で文字を入れたりしてるので、
値と書式をコピーしないとうまくいかなかったのです。
新しいマクロを作成させて、
つくったものでしたので、不必要なものがたくさんできていたように
思います。
投稿日時 - 2010-02-22 11:05:47
