Excel VBA質問箱 IV

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

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


1706 / 13646 ツリー ←次へ | 前へ→

【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")) も、どこのシートということが明示的に
示されていませんね。
こういう場合、VBAは、標準モジュールであればアクティブシート、
シートモジュールであれば、そのモジュールが属しているシートと見なします。

そうしますと、標準モジュールの場合、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列のデータ最終まで繰り返す場合の基本的な構文を以下に2つほど。
一般には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

1706 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free