エクセルＶＢＡ－カウンター i と j の使い方

質問

2つの条件を同時に満たすと図形を別のワークシートにコピーし、６００行程度あるワークシートなので For - Next を使ってその作業を繰り返す、というエクセルのマクロを以下のように書き込みました。ところがマクロを実行すると、一番最初の行だけ正確に実行され、次に条件を満たす行があっても図形がコピーされません。（ということはカウンター i, j の使い方が間違っているのです）どなたか私の素人コードを見て修正方法を教えてください。お願いします。

Sub finalize()
Dim MyStr As String
Dim i As Long
Dim j As Long
　For j = 2 To 1482 Step 40
For i = 3 To 188 Step 5
MyStr = Range("O" & i)
If MyStr <> "" Then　　　　　　　　　　　　　　　　　　　　'条件１
If Range("L" & i).Value = "毎日" Then　　　　　　'条件２　　
Sheets("図形＿現読").Select
ActiveSheet.Shapes.Range(Array("毎日")).Select
Selection.Copy
Sheets("印刷画面").Select
Range("AG" & j).Select
ActiveSheet.Paste
Else
If Range("L" & i).Value = "朝刊" Then
Sheets("図形＿現読").Select
ActiveSheet.Shapes.Range(Array("朝刊")).Select
Selection.Copy
Sheets("印刷画面").Select
Range("AG" & j).Select
ActiveSheet.Paste
End If
End If
End If
Next i
Next j
Ｅnd Sub

回答No.8

KURUMITO · ベストアンサー

回答2です。次のようにするとよいでしょう。
表が入力されているシート(シート1とします）、図形の入力されているシート、表のデータに基づいて図形を貼り付ける印刷用のシートが有るのでしょうか、そのようにして対応するとします。
Sub finalize()
Dim MyStr As String
Dim i As Long
Dim j As Long
Set WS1=Sheets("Sheet1")
Set WS2=Sheets("図形＿現読")
Set WS3=Sheets("印刷画面")
Application.ScreenUpdating = False
j = 2　
For i = 3 To 188 Step 5
MyStr = WS1.Range("O" & i)
If MyStr = "" Then Exit For　　　　　　　　　　　　　　　　　　　　'条件１
If WS1.Range("L" & i).Value = "毎日" Then　　　　　　'条件２　　
WS2.Select
ActiveSheet.Shapes.Range(Array("毎日")).Select
Selection.Copy
WS3.Select
WS3.Range("AG" & j).Select
ActiveSheet.Paste
j = j + 40
End If
If WS1.Range("L" & i).Value = "朝刊" Then
WS2.Select
ActiveSheet.Shapes.Range(Array("朝刊")).Select
Selection.Copy
WS3.Select
WS3.Range("AG" & j).Select
ActiveSheet.Paste
j = j + 40
End If
Next i
Application.ScreenUpdating = True
Ｅnd Sub

お礼

お礼が遅れてすみません（今日も一日仕事だったもので。）今自宅に戻って早速試しました。残念ながら同じ結果でした。でもいろいろと教えてくださってありがとうございました。書いてくださったコードは大事にとっておいて再利用させていただきます。もう少し繰り返しコードの基礎的な事を自習して、再度チャレンジします。

回答No.7

mu2011

>一番最初の行だけ正確に実行され、次に条件を満たす行があっても図形がコピーされません。
　⇒多分、標準モジュールで登録しているとプロシージャ内でシート選択するとシートオブジェクトを指定しないコードはそのシートで認識する為、１行目だけ動作することになりますのでご注意ください。
　　因みに変数ｊはｉループが終わるまで同一ですのでご注意ください。

　シート選択しないでコピーできる一例です。（コードが冗長なのでダイエットしています）
　データシートを選択した状態でマクロ実行してください。

Sub finalize()
Dim i As Long
Dim j As Long
j = 2
For i = 3 To 188 Step 5
If Range("O" & i) <> "" Then
If Range("L" & i) = "毎日" Or _
Range("L" & i) = "朝刊" Then
Sheets("図形＿現読").Shapes(Range("L" & i)).Copy
ActiveSheet.Paste Sheets("印刷画面").Cells(j, "AG")
End If
End If
j = j + 40
Next i
End Sub

お礼

お礼が遅くなってすみませんでした。実は数々の回答を試したのですが全然うまくいかず、あきらめて何度も投稿してくださった方の回答をベストアンサーに選んでしまいました。そしてすぐ後にこのコードをコピーして試したらナント成功しました。本当にありがとうございます。そしてベストアンサーに選び損ねたことをお詫び申し上げます。

回答No.6

nicotinism

見辛いので整形とイミディエイトウィンドウにシート名を出力するようにしただけです。
Tab インデントの代わりに全角スペースにしていますのでエラーになるかも。
手掛かりにはなるかと。

Sub finalize()
Dim MyStr As String
Dim i As Long
Dim j As Long
For j = 2 To 1482 Step 40
　　For i = 3 To 188 Step 5
　　　　MyStr = Range("O" & i)
　　　　Debug.Print MyStr, Range("O" & i).Parent.Name
　　　　If MyStr <> "" Then　　　　　　　　　　　　　　　　　　　　'条件１
　　　　　　Debug.Print Range("L" & i).Parent.Name
　　　　　　If Range("L" & i).Value = "毎日" Then　　　　　　'条件２
　　　　　　　　Sheets("図形＿現読").Range(Array("毎日")).Copy _
　　　　　　　　 Destination:=Sheets("印刷画面").Range("AG" & j)
　　　　　　ElseIf Range("L" & i).Value = "朝刊" Then
　　　　　　　　Sheets("図形＿現読").Range(Array("朝刊")).Copy _
　　　　　　　　 Destination:=Sheets("印刷画面").Range("AG" & j)
　　　　　　End If
　　　　End If
　　Next i
Next j
End Sub

お礼

お礼が遅くなってすみません。コードをコピーして試しましたが、最期の図形のコピーの部分でエラーがでました。でも書いてくださったコードは大事に保管して再利用させていただきます。もう少し基礎的な事を自習してから再度チャレンジするつもりです。ありがとうございました。

回答No.5

nag0720

＃４です。

＞シートを元に戻すコードを加えると、図形の貼り付けが無限にしかも条件に即しない箇所にも起こってエラーになります。

プログラムを見ると、
１つの行で条件１、条件２を満たすと、図形を３８回貼り付けしています。
だから、もし１０の行で条件を満たせば３８０回貼り付けすることになります。
そのような仕様なのでしょうか？

エラーの原因はメモリー不足でしょう。

お礼

お礼が遅くなってすみません。今朝いただいた回答の中に１つだけうまく実行できたコードがありました。もう少し基礎的な事を自習して、次回は自分が書くコードの意味をよくわかってから質問します。お休みの日にどうもありがとうございました。

回答No.4

nag0720

Sheets("図形＿現読").Select
や
Sheets("印刷画面").Select
でアクティブシートを変えていますが、
Range("O" & i)やRange("L" & i)はどのシートのRangeなんでしょうか？

もしこれが"印刷画面"シートなら問題ないですが、そうでなければループの最初または最後にアクティブシートを元に戻しておかなければなりません。

お礼

お礼が遅くなってすみません。今朝いただいた回答の中から、１つだけうまく実行できたコードがありました。次回はもう少し自習をしてからコードを書くように心がけます。ありがとうございました。

補足

シートを元に戻すコードを加えると、図形の貼り付けが無限にしかも条件に即しない箇所にも起こってエラーになります。シートを指定するコードの挿入場所を変えていくつか試しましたが、全く変化なし、もしくは無限なコポー＆貼り付けでエラー、という結果になります。

回答No.3

KURUMITO

回答2は無視してください。
次のようにコードを変えてみてはどうでしょう。
Sub finalize()
Dim MyStr As String
Dim i As Long
Dim j As Long
j = 2　
For i = 3 To 188 Step 5
MyStr = Range("O" & i)
If MyStr <> "" Then　　　　　　　　　　　　　　　　　　　　'条件１
If Range("L" & i).Value = "毎日" Then　　　　　　'条件２　　
Sheets("図形＿現読").Select
ActiveSheet.Shapes.Range(Array("毎日")).Select
Selection.Copy
Sheets("印刷画面").Select
Range("AG" & j).Select
ActiveSheet.Paste
j = j + 40
Else
If Range("L" & i).Value = "朝刊" Then
Sheets("図形＿現読").Select
ActiveSheet.Shapes.Range(Array("朝刊")).Select
Selection.Copy
Sheets("印刷画面").Select
Range("AG" & j).Select
ActiveSheet.Paste
j = j + 40
End If
End If
End If
Next i

Ｅnd Sub

補足

ありがとうございます。言われた通りに試しましたが同じ結果でした。Exit For　を使ってＥｎｄ　Ｉｆ　を一個削除することも試しましたが、やはりだめでした。最初練習するとき同じワークシート内で、カウンター　i　だけつかって（step　は無）でマクロを書き、試したらうまくいきました。そしてそのマクロにカウンター　j を追加し、ワークシートを変える操作を加えただけなんですけど、、、おそらく繰り返し操作のコードの書き方がまちがっていると思います。もう少し頑張ります。ありがとうございました。

回答No.2

KURUMITO

次のように一部を変更して試験してみてください。

If MyStr <> "" Then　は
If MyStr <> "" Then　Exit For

End If は一つを削除します。

回答No.1

atamagawarui5

デバックしましたか？

F8でステップデバックしてみてください。

人のプログラム検証デバック面倒くさいので、ローカルウィンドウ、イミディエイトウィンドウ、ウオッチウィンドウ表示させておけば、カウンタの中身みれすでしょ。