Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

1705 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

▼

【72481】sheet1のデータをsheet2に整形して抽出する方法 タケル 12/8/15(水) 14:45

【72484】Re:sheet1のデータをsheet2に整形して抽出... UO3 12/8/15(水) 19:54

【72487】Re:sheet1のデータをsheet2に整形して抽出... タケル 12/8/15(水) 22:17

【72488】Re:sheet1のデータをsheet2に整形して抽出... タケル 12/8/15(水) 22:36

【72496】Re:sheet1のデータをsheet2に整形して抽出... kanabun 12/8/16(木) 9:28

【72501】Re:sheet1のデータをsheet2に整形して抽出... UO3 12/8/16(木) 15:57

【72490】Re:sheet1のデータをsheet2に整形して抽出... UO3 12/8/15(水) 22:40


	【72481】sheet1のデータをsheet2に整形して抽出す...

タケル - 12/8/15(水) 14:45 -


	引用なし

	パスワード

【sheet1】に

　　 A　,　B ,　C　,　D　,　E　,　F　,　G　,　H　,　I　,　J　,　K　,
1　_____,____,項目1,項目2,項目3,項目4,項目5,項目6,項目7,項目8,項目9,
2　_____,____,_____,_____,_____,_____,_____,_____,_____,_____,_____,←空白の行
3　東京 , 12 ,　c3 ,　d3 ,　e3 ,　f3 ,　g3 ,　h3 ,　i3 ,　j3 ,　k3 ,
4　東京 , 12 ,　c4 ,　d4 ,　e4 ,　f4 ,　g4 ,　h4 ,　i4 ,　j4 ,　k4 ,
5　東京 , 12 ,　c5 ,　d5 ,　e5 ,　f5 ,　g5 ,　h5 ,　i5 ,　j5 ,　k5 ,
6　東京 , 12 ,　c6 ,　d6 ,　e6 ,　f6 ,　g6 ,　h6 ,　i6 ,　j6 ,_____,
7　東京 , 12 ,　c7 ,　d7 ,　e7 ,　f7 ,　g7 ,　h7 ,　i7 ,　j7 ,_____,
8　東京 , 12 ,　c8 ,　d8 ,　e8 ,　f8 ,　g8 ,　h8 ,　i8 ,　j8 ,_____,
9　東京 , 12 ,　c9 ,　d9 ,　e9 ,　f9 ,　g9 ,　h9 ,　i9 ,　j9 ,_____,
10 東京 , 12 , c10 , d10 , e10 , f10 , g10 , h10 , i10 , j10 ,_____,
11 東京 , 12 , c11 , d11 , e11 , f11 , g11 , h11 , i11 , j11 ,_____,
12 東京 , 12 , c12 , d12 , e12 , f12 , g12 , h12 , i12 , j12 ,_____,
13 東京 , 12 , c13 , d13 , e13 , f13 , g13 , h13 , i13 , j13 ,_____,
14 東京 , 12 , c14 , d14 , e14 , f14 , g14 , h14 , i14 , j14 ,_____,
15 _____,____,_____,_____,_____,_____,_____,_____,_____,_____,_____,←空白の行
16 京都 , 15 , c16 , d16 , e16 , f16 , g16 , h16 , i16 , j16 , k16 ,
17 京都 , 15 , c17 , d17 , e17 , f17 , g17 , h17 , i17 , j17 , k17 ,
18 京都 , 15 , c18 , d18 , e18 , f18 , g18 , h18 , i18 , j18 , k18 ,
19 京都 , 15 , c19 , d19 , e19 , f19 , g19 , h19 , i19 , j19 ,_____,
20 京都 , 15 , c20 , d20 , e20 , f20 , g20 , h20 , i20 , j20 ,_____,
21 京都 , 15 , c21 , d21 , e21 , f21 , g21 , h21 , i21 , j21 ,_____,
22 京都 , 15 , c22 , d22 , e22 , f22 , g22 , h22 , i22 , j22 ,_____,
23 京都 , 15 , c23 , d23 , e23 , f23 , g23 , h23 , i23 , j23 ,_____,
24 京都 , 15 , c24 , d24 , e24 , f24 , g24 , h24 , i24 , j24 ,_____,
25 京都 , 15 , c25 , d25 , e25 , f25 , g25 , h25 , i25 , j25 ,_____,
26 京都 , 15 , c26 , d26 , e26 , f26 , g26 , h26 , i26 , j26 ,_____,
27 京都 , 15 , c27 , d27 , e27 , f27 , g27 , h27 , i27 , j27 ,_____,
28 京都 , 15 , c28 , d28 , e28 , f28 , g28 , h28 , i28 , j28 ,_____,
29 京都 , 15 , c29 , d29 , e29 , f29 , g29 , h29 , i29 , j29 ,_____,
30 京都 , 15 , c30 , d30 , e30 , f30 , g30 , h30 , i30 , j30 ,_____,
31_____,____,_____,_____,_____,_____,_____,_____,_____,_____,_____,←空白の行
32 愛知 , 11 , c32 , d32 , e32 , f32 , g32 , h32 , i32 , j32 , k32 ,
33 愛知 , 11 , c33 , d33 , e33 , f33 , g33 , h33 , i33 , j33 , k33 ,
34 愛知 , 11 , c34 , d34 , e34 , f34 , g34 , h34 , i34 , j34 , k34 ,
35 愛知 , 11 , c35 , d35 , e35 , f35 , g35 , h35 , i35 , j35 ,_____,
36 愛知 , 11 , c36 , d36 , e36 , f36 , g36 , h36 , i36 , j36 ,_____,
37 愛知 , 11 , c37 , d37 , e37 , f37 , g37 , h37 , i37 , j37 ,_____,
38 愛知 , 11 , c38 , d38 , e38 , f38 , g38 , h38 , i38 , j38 ,_____,
39 愛知 , 11 , c39 , d39 , e39 , f39 , g39 , h39 , i39 , j39 ,_____,
40 愛知 , 11 , c40 , d40 , e40 , f40 , g40 , h40 , i40 , j40 ,_____,
41 愛知 , 11 , c41 , d41 , e41 , f41 , g41 , h41 , i41 , j41 ,_____,
42 愛知 , 11 , c42 , d42 , e42 , f42 , g42 , h42 , i42 , j42 ,_____,
43_____,____,_____,_____,_____,_____,_____,_____,_____,_____,_____,←空白の行
44
・
・
・
上記のようなデータがあり，これを【sheet2】に
　　 A　 ,　B　,　 d　,　D , E , F , G , H , I , J , K , L , M , N , O , …, R , …,　V　,
1　地区　,ﾃﾞｰﾀ数,順位 , 1位,2位,3位,4位,5位,6位,7位, …, …, …, …, …, …, …, …, ……,
2　　　　,　　 , 項目1,　d3, d4, d5, d6, d7, d8, d9,d10,d11,d12,d13,d14, …, …, …,項目7,
3　　　　,　　 , 項目2,　e3, e4, e5, e6, e7, e8, e9,e10,e11,e12,e13,e14, …, …, …,　j3 ,
4　東京 , 12　, 項目3,　f3, f4, f5, f6, f7, f8, f9,f10,f11,f12,f13,f14, …, …, …,項目8,
5　　　　,　　 , 項目4,　g3, g4, g5, g6, g7, g8, g9,g10,g11,g12,g13,g14, …, …, …,　k3 ,
6　　　　,　　 , 項目5,　h3, h4, h5, h6, h7, h8, h9,h10,h11,h12,h13,h14, …, …, …,　k4 ,
7 ________,______, 項目6,　i3, i4, i5, i6, i7, i8, i9,i10,i11,i12,i13,i14, …, …, …,　k5 ,
8　　　　,　　 , 項目1, d16,d17,d18,d19,d20,d21,d22,d23,d24,d25, …, …, …,d30,___,項目7
9　　　　,　　 , 項目2, e16,e17,e18,e19,e20,e21,e22,e23,e24,e25, …, …, …,e30,___, j16 ,
10　　　 ,　　 , 項目3, f16,f17,f18,f19,f20,f21,f22,f23,f24,f25, …, …, …,f30,___,項目8,
11 京都 , 15　, 項目4, g16,g17,g18,g19,g20,g21,g22,g23,g24,g25, …, …, …,g30,___, k16 ,
12　　　 ,　　 , 項目5, h16,h17,h18,h19,h20,h21,h22,h23,h24,h25, …, …, …,h30,___, k17 ,
13 _______,______, 項目6, i16,i17,i18,i19,i20,i21,i22,i23,i24,i25, …, …, …,i30,___, k18 ,
14　　　 ,　　 , 項目1, d32,d33,d34,d35,d36,d37,d38,d39,d40,d41,d42, …, …, …, …,項目8,
15　　　 ,　　 , 項目2, e32,e33,e34,e35,e36,e37,e38,e39,e40,e41,e42, …, …, …, …, j32,
16　　　 ,　　 , 項目3, f32,f33,f34,f35,f36,f37,f38,f39,f40,f41,f42, …, …, …, …,項目9,
17 愛知 , 11 , 項目4, g32,g33,g34,g35,g36,g37,g38,g39,g40,g41,g42, …, …, …, …, k32 ,
18　　　 ,　　 , 項目5, h32,h33,h34,h35,h36,h37,h38,h39,h40,h41,h42, …, …, …, …, k33 ,
19 _______,_____, 項目6, i32,i33,i34,i35,i36,i37,i38,i39,i40,i41,i42, …, …, …, …, k34 ,
・
・
・

というように表示させるために、下記のようにコードを書いたのですが，
望んでいる結果が得られません．
------------------------------------------------------------------------
Sub コピペ()

i = 2
j = 2

m = 2
n = 3
o = 4
p = 5
q = 6
r = 7

p01:
Application.DisplayAlerts = False
If Cells(i, "A") = "" Then
　　 Sheets(1).Cells(i + 1, "A").Copy Sheets(2).Cells(j, "A")
　　 Sheets(2).Range(Cells(j, "A"), Cells(j + 5, "A")).MergeCells = True
　　
　　 Sheets(1).Cells(i + 1, "B").Copy Sheets(2).Cells(j, "B")
　　 Sheets(2).Range(Cells(j, "B"), Cells(j + 5, "B")).MergeCells = True

　　 Sheets(1).Cells(i + 1, "J").Copy Sheets(2).Cells(j + 1, "V")
　　 Sheets(1).Cells(i + 1, "K").Copy Sheets(2).Cells(j + 3, "V")
　　 Sheets(1).Cells(i + 2, "K").Copy Sheets(2).Cells(j + 4, "V")
　　 Sheets(1).Cells(i + 3, "K").Copy Sheets(2).Cells(j + 5, "V")
　　　　　
　　 j = j + 6

ElseIf Cells(i, "A") <> "" Then
　　 Y = Cells(i, "B").Value
　　
　　 Sheets(1).Range(Cells(i, "D"), Cells(i + Y - 1, "D")).Copy Sheets(2).Range(Cells(m, 4), Cells(m, 4 + Y))←「型が違います」と表示され処理ができない．
　　 m = m + 6
　　 Sheets(1).Range(Cells(i, "E"), Cells(i + Y - 1, "E")).Copy Sheets(2).Range(Cells(n, 4), Cells(n, 4 + Y))
　　 n = n + 6
　　 Sheets(1).Range(Cells(i, "F"), Cells(i + Y - 1, "F")).Copy Sheets(2).Range(Cells(o, 4), Cells(o, 4 + Y))
　　 o = o + 6
　　 Sheets(1).Range(Cells(i, "G"), Cells(i + Y - 1, "G")).Copy Sheets(2).Range(Cells(p, 4), Cells(p, 4 + Y))
　　 p = p + 6
　　 Sheets(1).Range(Cells(i, "H"), Cells(i + Y - 1, "H")).Copy Sheets(2).Range(Cells(q, 4), Cells(q, 4 + Y))
　　 q = q + 6
　　 Sheets(1).Range(Cells(i, "I"), Cells(i + Y - 1, "I")).Copy Sheets(2).Range(Cells(r, 4), Cells(r, 4 + Y))
　　 r = r + 6
　　
Else
End If
i = i + 1
Application.DisplayAlerts = True
GoTo p01
End Sub
------------------------------------------------------------------------

どのように書き換えれば，望んだ結果が得られるでしょうか？
アドバイスをお願いします．


	【72484】Re:sheet1のデータをsheet2に整形して抽...

UO3 - 12/8/15(水) 19:54 -


	引用なし

	パスワード

▼タケルさん：

こんばんは

アップされたサンプルデータも、まだ見ていませんし、コードも、ざらっと眺めただけですが、
ループ構文の書き方としては、大いに改善すべき点はあるとして、

まず、ほんとうに『型が違います』というエラーでしたか？
1004 で、『不適切です』といったエラーではなかったですか？

>　　 Sheets(1).Range(Cells(i, "D"), Cells(i + Y - 1, "D")).Copy Sheets(2).Range(Cells(m, 4), Cells(m, 4 + Y))←「型が違います」と表示され処理ができない．

これはSheets(1)のD列の『縦』の領域を、Sheets(2)のD○から右の『横』の領域にコピペしようとしていますね。

コピーの後のペースト操作で行列を入れ替えというのがありますね。
それをシートの上で実行して、それをマクロ記録してみてください。
PasteSpecial で　Transposeが指定されたコードが生成されるはずです。

それと、なぜ

Application.DisplayAlerts = False

が、あるのでしょう？
ざっと見る限り、これが必要なコード実行は見あたりませんが？


	【72487】Re:sheet1のデータをsheet2に整形して抽...

タケル - 12/8/15(水) 22:17 -


	引用なし

	パスワード

▼UO3 さん：
返信ありがとうございます。

>アップされたサンプルデータも、まだ見ていませんし、コードも、ざらっと眺めただけですが、
>ループ構文の書き方としては、大いに改善すべき点はあるとして、

申し訳ありません。問題点が多くあることはわかってはいますが、
自分なりにやった結果、これ以上の改善方法がわからなかったので、
そちらも助言を頂けると嬉しいです。

>まず、ほんとうに『型が違います』というエラーでしたか？
>1004 で、『不適切です』といったエラーではなかったですか？
>
>>Sheets(1).Range(Cells(i, "D"), Cells(i + Y - 1, "D")).Copy Sheets(2).Range(Cells(m, 4), Cells(m, 4 + Y))←「型が違います」と表示され処理ができない．
>これはSheets(1)のD列の『縦』の領域を、Sheets(2)のD○から右の『横』の領域にコピペしようとしていますね。

やりたい処理は、おっしゃる通りです。
確かに「型が一致しません」というエラーでした。
ただ、行列入れ替えを試してみましたので、新しいコードを記載させていただきます。

>それと、なぜ
>Application.DisplayAlerts = False
>が、あるのでしょう？
>ざっと見る限り、これが必要なコード実行は見あたりませんが？

申し訳ありません。上記のコードは不要でしたので、
消去しました。

また、コードを張らせていただきますので、
改善点がございましたら、お手数ですがご返信を頂けると幸いです。

--------------------------------------------------------------------------
Sub コピペ()

i = 2
j = 2

m = 2
n = 3
o = 4
p = 5
q = 6
r = 7

p01:
If Cells(i, "A") = "" Then
　　 Sheets(1).Cells(i + 1, "A").Copy Sheets(2).Cells(j, "A")
　　 Sheets(2).Range(Cells(j, "A"), Cells(j + 5, "A")).MergeCells = True 'アプリケーション定義またはオブジェクト定義のエラー（上手く行く時もある）
　　
　　 Sheets(1).Cells(i + 1, "B").Copy Sheets(2).Cells(j, "B")
　　 Sheets(2).Range(Cells(j, "B"), Cells(j + 5, "B")).MergeCells = True

　　 Sheets(1).Cells(i + 1, "J").Copy Sheets(2).Cells(j + 1, "V")
　　 Sheets(1).Cells(i + 1, "K").Copy Sheets(2).Cells(j + 3, "V")
　　 Sheets(1).Cells(i + 2, "K").Copy Sheets(2).Cells(j + 4, "V")
　　 Sheets(1).Cells(i + 3, "K").Copy Sheets(2).Cells(j + 5, "V")
　　　　　
　　 j = j + 6

　　 Y = Cells(i + 1, "B").Value
　　
　　 Sheets(1).Range(Cells(i + 1, "D"), Cells(i + Y, "D")).Select
　　 Selection.Copy
　　 Sheets(2).Select
　　 Range(Cells(m, 4), Cells(m, 4 + Y)).Select
　　 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　False, Transpose:=True
　　 m = m + 6
　　
　　 Sheets(1).Range(Cells(i + 1, "E"), Cells(i + Y, "E")).Select 'アプリケーション定義またはオブジェクト定義のエラーが発生
　　 Selection.Copy
　　 Sheets(2).Select
　　 Range(Cells(n, 4), Cells(n, 4 + Y)).Select
　　 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　False, Transpose:=True
　　 n = n + 6
　　
　　 Sheets(1).Range(Cells(i + 1, "F"), Cells(i + Y, "F")).Select
　　 Selection.Copy
　　 Sheets(2).Select
　　 Range(Cells(o, 4), Cells(o, 4 + Y)).Select
　　 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　False, Transpose:=True
　　 o = o + 6
　　
　　 Sheets(1).Range(Cells(i + 1, "G"), Cells(i + Y, "G")).Select
　　 Selection.Copy
　　 Sheets(2).Select
　　 Range(Cells(p, 4), Cells(p, 4 + Y)).Select
　　 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　False, Transpose:=True
　　 p = p + 6
　　
　　 Sheets(1).Range(Cells(i + 1, "H"), Cells(i + Y, "H")).Select
　　 Selection.Copy
　　 Sheets(2).Select
　　 Range(Cells(q, 4), Cells(q, 4 + Y)).Select
　　 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　False, Transpose:=True
　　 q = q + 6
　　
　　 Sheets(1).Range(Cells(i + 1, "I"), Cells(i + Y, "I")).Select
　　 Selection.Copy
　　 Sheets(2).Select
　　 Range(Cells(r, 4), Cells(r, 4 + Y)).Select
　　 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　False, Transpose:=True
　　 r = r + 6
　　
Else
End If
i = i + 1
GoTo p01
End Sub


	【72488】Re:sheet1のデータをsheet2に整形して抽...

タケル - 12/8/15(水) 22:36 -


	引用なし

	パスワード

UO3さんへ
欲しい処理ができました。
ありがとうございます。
ただ、もう少しこうしたほうが処理が速くなるとか、
何かアドバイスがいただければ幸いです。

それから、sheet1にデータがなくなったときに
処理を終わらせるためには、どうしたらよろしいでしょうか？

--------------------------------------------------------------------------

Sub コピペ()

i = 2
j = 2

m = 2
n = 3
o = 4
p = 5
q = 6
r = 7

p01:
If Cells(i, "A") = "" Then
　　 Sheets(1).Cells(i + 1, "A").Copy Sheets(2).Cells(j, "A")
　　 Sheets("sheet2").Select
　　 Sheets(2).Range(Cells(j, "A"), Cells(j + 5, "A")).MergeCells = True 'アプリケーション定義またはオブジェクト定義のエラー（上手く行く時もある）
　　 Sheets("sheet1").Select
　　
　　 Sheets(1).Cells(i + 1, "B").Copy Sheets(2).Cells(j, "B")
　　 Sheets("sheet2").Select
　　 Sheets(2).Range(Cells(j, "B"), Cells(j + 5, "B")).MergeCells = True
　　 Sheets("sheet1").Select

　　 Sheets(1).Cells(i + 1, "J").Copy Sheets(2).Cells(j + 1, "V")
　　 Sheets(1).Cells(i + 1, "K").Copy Sheets(2).Cells(j + 3, "V")
　　 Sheets(1).Cells(i + 2, "K").Copy Sheets(2).Cells(j + 4, "V")
　　 Sheets(1).Cells(i + 3, "K").Copy Sheets(2).Cells(j + 5, "V")
　　　　　
　　 j = j + 6

　　 Y = Sheets("sheet1").Cells(i + 1, "B").Value
　　
　　 Sheets(1).Range(Cells(i + 1, "D"), Cells(i + Y, "D")).Select
　　 Selection.Copy
　　 Sheets(2).Select
　　 Range(Cells(m, 4), Cells(m, 4 + Y)).Select
　　 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　False, Transpose:=True
　　 m = m + 6
　　 Sheets("sheet1").Select
　　
　　
　　 Sheets(1).Range(Cells(i + 1, "E"), Cells(i + Y, "E")).Select 'アプリケーション定義またはオブジェクト定義のエラーが発生
　　 Selection.Copy
　　 Sheets(2).Select
　　 Range(Cells(n, 4), Cells(n, 4 + Y)).Select
　　 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　False, Transpose:=True
　　 n = n + 6
　　 Sheets("sheet1").Select
　　
　　 Sheets(1).Range(Cells(i + 1, "F"), Cells(i + Y, "F")).Select
　　 Selection.Copy
　　 Sheets(2).Select
　　 Range(Cells(o, 4), Cells(o, 4 + Y)).Select
　　 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　False, Transpose:=True
　　 o = o + 6
　　 Sheets("sheet1").Select
　　
　　 Sheets(1).Range(Cells(i + 1, "G"), Cells(i + Y, "G")).Select
　　 Selection.Copy
　　 Sheets(2).Select
　　 Range(Cells(p, 4), Cells(p, 4 + Y)).Select
　　 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　False, Transpose:=True
　　 p = p + 6
　　 Sheets("sheet1").Select
　　
　　 Sheets(1).Range(Cells(i + 1, "H"), Cells(i + Y, "H")).Select
　　 Selection.Copy
　　 Sheets(2).Select
　　 Range(Cells(q, 4), Cells(q, 4 + Y)).Select
　　 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　False, Transpose:=True
　　 q = q + 6
　　 Sheets("sheet1").Select
　　
　　 Sheets(1).Range(Cells(i + 1, "I"), Cells(i + Y, "I")).Select
　　 Selection.Copy
　　 Sheets(2).Select
　　 Range(Cells(r, 4), Cells(r, 4 + Y)).Select
　　 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　False, Transpose:=True
　　 r = r + 6
　　 Sheets("sheet1").Select
　　
Else
End If
i = i + 1
GoTo p01
End Sub

--------------------------------------------------------------------------


	【72490】Re:sheet1のデータをsheet2に整形して抽...

UO3 - 12/8/15(水) 22:40 -


	引用なし

	パスワード

▼タケルさん：

ループ構文の改善は、後回しにして

>
>　　 Sheets(2).Range(Cells(j, "A"), Cells(j + 5, "A")).MergeCells = True 'アプリケーション定義またはオブジェクト定義のエラー（上手く行く時もある）
>　　
>　　
>　　 Sheets(1).Range(Cells(i + 1, "E"), Cells(i + Y, "E")).Select 'アプリケーション定義またはオブジェクト定義のエラーが発生
>　　 Sheets(1).Range(Cells(i + 1, "H"), Cells(i + Y, "H")).Select

うっかりと、このような記述をしてしまい、悩む人が多いようですね。

Sheets(2).Range(

こは、Sheets(2)の領域の宣言をします。その詳細は (・・) のなかに記述していますと
こういうことを意味しています。
で、その (・・・・) の中ですが、このセルからこのセルまで　こういう記述ですよね。
でも、『このセル』って、どこのシートのセルでしょうか？
Cells(i + 1, "H")　も Cells(i + Y, "H"))　も、どこのシートということが明示的に
示されていませんね。
こういう場合、ＶＢＡは、標準モジュールであればアクティブシート、
シートモジュールであれば、そのモジュールが属しているシートと見なします。

そうしますと、標準モジュールの場合、Sheets(2)がアクティブシートなら結果オーライですが
それ以外がアクティブになっていると、
Sheets(2)のセル領域の規定で、その詳細は、Sheets(2)以外のここからここまで。
このような矛盾のある規定になりますのでアプリケーション定義エラーとなります。
(・・・・) の中のセルにも SHeets(2). とシート修飾することが必要です。


	【72496】Re:sheet1のデータをsheet2に整形して抽...

kanabun - 12/8/16(木) 9:28 -


	引用なし

	パスワード

▼タケルさん：よこから失礼します >'アプリケーション定義またはオブジェクト定義のエラー（上手く行く時もある） >　　 Sheets("sheet1").Select >　　 Sheets(1).Range(Cells(i + 1, "G"), Cells(i + Y, "G")).Select >　　 Selection.Copy Cellsのまえにシートの指定がないため、上記のエラーが（アクティブなシートが "Sheet1"でないとき）発生する、という説明がありました。そのとおりなんで、上の3行はは　　 Sheets(1).Select 　　 Range(Cells(i + 1, "G"), Cells(i + Y, "G")).Copy の2行か、より簡潔には　　 Sheets(1).Cells(i + 1, "G").Resize(Y).Copy の一行ってことですよね？（下はシートの選択が不要です）


	【72501】Re:sheet1のデータをsheet2に整形して抽...

UO3 - 12/8/16(木) 15:57 -


	引用なし

	パスワード

▼タケルさん：

こんにちは

>もう少しこうしたほうが処理が速くなるとか、
>何かアドバイスがいただければ幸いです。

エクセルのシート上の処理で結構時間がかかるのは、セルへの書き込み行為、
それと、書き込んだ内容を今見えているエクセルの画面に反映させるための再描画処理です。

たとえば

Range("A1").Value = Range("D1").Value
Range("B1").Value = Range("E1").Value

こんなコードがあった場合、書き込みが2回、再描画が2回発生します。
これを

Range("A1:B1").Value = Range("D1:E1").Value

こうしますと、書き込みは1回、再描画も1回になりますので処理時間も短くなります。
さらに、プロシジャの先頭で

Application.ScreenUpDating = False と宣言しておきますと
エクセルによる再描画処理が休眠状態になりますので、実際の書き込み処理に要する時間だけで処理可能です。
で、お約束として、プロシジャの最後に
Application.ScreenUpDating = True
こうして、再描画を再開させます。
この時に、今まで休眠していた再描画機能が目を覚まして1回だけ、画面に再描画します。
（Application.ScreenUpDating は、ほぉっておいても、End Sub でリセットされますが）

2003までであれば、このApplication.ScreenUpDating による処理記述で、処理時間は、おおよそ半減でした。
残念ながら、2007以降は、セルへの書き込み負荷に比べて再描画負荷が小さいので、この手当をしても
しない場合より、わずかにまし　ぐらいなんですが。

それより、セルへの書き込み回数を減らす方が効果が大きいですね。
極端に言えば1回だけにするとか。
そうすると、再描画のことも気にする必要はなくなります。
ただ、これは猛さんにとっては、なかなか簡単ではないかもしれません。

>それから、sheet1にデータがなくなったときに
>処理を終わらせるためには、どうしたらよろしいでしょうか？

A2からはじめて、A列のデータ最終まで繰り返す場合の基本的な構文を以下に２つほど。
一般にはSample1の形ですね。まずは、これらをしっかりと理解してください。

Sub Sample1()
　　Dim maxRow As Long
　　Dim i As Long
　　
　　maxRow = Range("A" & Rows.Count).End(xlUp).Row　'A列最終行番号
　　
　　For i = 2 To maxRow
　　
　　　　' i 行目の処理
　　　　
　　Next
　　
End Sub

Sub Sample2()
　　Dim i As Long
　　
　　i = 2
　　
　　Do While Cells(i, "A").Value <> ""　'A列のセルが空白になるまで実行
　　
　　　　' i 行目の処理
　　　　
　　　　i = i + 1
　　　　
　　Loop
　　
End Sub


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

1705 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free