Excel VBA質問箱 IV

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

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


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

16 / 3840 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【82162】Re:グラフのコピー

あおこ - 23/6/14(水) 16:31 -


	引用なし

	パスワード

▼マナさん：
>▼あおこさん：
>
>こんな感じで書き直すとどうなりますか？
>Sheet1のグラフ雛形を繰り返しSheet2にコピーする例です。

ご回答ありがとうございます。
ご提示のコードを試させていただきました。
（少し変更しています。）

Sheet2.Paste Sheet2.Range("k17").Offset(k * 17)のところで
実行時エラー1004「WorksheetクラスのPasteメソッドが失敗しました」
のエラーで処理が止まりますので
DoEvents　も書き足しました。（ネットで見つけた解決法です。あまり良くないでしょうか？）

Sub test()
　　Dim cho As ChartObject
　　Dim k As Long
　　Dim H As Double, W As Double
　　
　　Set sh_A2 = Worksheets("学校")
　　
　　Set cho = Worksheets("基本グラフ").ChartObjects(1)
　　H = sh_A2.Range("A1:A15").Height
　　W = sh_A2.Range("K1:S1").Width
　　k=0

　　Do
　　　　cho.Copy
　　　　sh_A2.Activate
　　　　DoEvents
　　　　sh_A2.Paste sh_A2.Range("k17").Offset(k * 17)
　　　　With sh_A2.ChartObjects(k + 1)
'　　　　　　.Chart.SetSourceData Source:=R
'　　　　　　.Chart.ChartTitle.Text = R(1).Value
　　　　　　.Height = H
　　　　　　.Width = W
　　　　End With
　　　　k = k + 1
　　Loop Until k > 8
　　
End Sub

上記コードで、今回のアンケートの質問数9個のグラフが問題なくコピーされ、繰り返し試しても落ちることはありませんでしたので、下記のように全体のコードを変更してみました。
変更後、15回ほど繰り返して処理を行いましたが、今のところ大丈夫のようです。

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

ちなみに、他でも使えるように、できれば、グラフ終端を取得して次のグラフの位置決めをしたいのですが、当初こちらが記載していたコード（↓）だと動きが遅いんでしょうか？

G_GYO = .ChartObjects(.ChartObjects.Count).BottomRightCell.Row + 2 'グラフの右下のセルの行
でグラフコピーの都度セル位置を取得

最初、その部分を残してコードを走らせたら、けっこうな確率で「応答なし」となり落ちました。。

ご提示いただいた　.Paste .Range("k17").Offset(k * 17)の、「17」を都度変えていく方が無難でしょうか？

もしよろしければ、ご教示願えると幸いです。

Sub テスト指定校結果作成()

　Set wb_A = ThisWorkbook
　Set sh_A1 = wb_A.Worksheets("作業用")
　Set sh_A2 = wb_A.Worksheets("クロス集計_割合")
　Set sh_A3 = wb_A.Worksheets("基本グラフ")
　Set sh_A4 = wb_A.Worksheets("結果ひな形")
　
　
　 Application.DisplayAlerts = False
　 Application.ScreenUpdating = False
　 gakko = sh_A1.Range("I14")
　
　 '’学校名シートがないか確認して追加、あれば削除するコードを記述（記載省略）
　
　'=======================================================================
　 Set sh_A5 = wb_A.Worksheets(gakko)
　 With sh_A5
　　 sh_A2.UsedRange.Copy
　　 .Activate
　　 .Range("A2").Select
　　 Selection.PasteSpecial Paste:=xlPasteAll
　　 Selection.PasteSpecial Paste:=xlPasteColumnWidths '＜書式（列幅）もコピー＞
　　 Application.CutCopyMode = False
　　
　　 lastRow1 = .Range("A" & Rows.Count).End(xlUp).Row
　　 .Rows("2:" & lastRow1).Select 'フォント変更
　　　Selection.Font.Size = 10
　　　Selection.Font.Name = "ＭＳＰゴシック"
　　　Selection.VerticalAlignment = xlCenter
　　　.Rows("2:200").RowHeight = 15
　　　' Selection.HorizontalAlignment = xlCenter
　　　ActiveWindow.Zoom = 80 '＜アクティブシートの表示を80％にします。＞

‘学校名からコードg_codeを参照する処理を記述（記載省略）
lastRow1 = .Range("A" & Rows.Count).End(xlUp).Row

'’不要行削除
　　 For GYO = lastRow1 To 2 Step -1
　　　If Left(.Cells(GYO, 1), 2) <> "質問" And .Cells(GYO, 1) <> "合計" And .Cells(GYO, 1) <> g_code Then
　　　 .Range(GYO & ":" & GYO).Delete
　　　End If
　　 Next GYO
　　
　　
　　 lastRow1 = .Range("A" & Rows.Count).End(xlUp).Row
　　 '質問番号追加及び0値クリア
　　 For GYO = 2 To lastRow1
　　　　If Left(.Cells(GYO, 1), 2) = "質問" Then
　　　　　　.Cells(GYO, 2) = Right(.Cells(GYO, 1), 1) & " " & .Cells(GYO, 2)
　　　　Else
　　　　　　lastcol1 = .Cells(GYO, Columns.Count).End(xlToLeft).Column '最終列を取得
　　　　　　For RETSU = 3 To lastcol1
　　　　　　　　If .Cells(GYO, RETSU) = 0 Then
　　　　　　　　　　.Cells(GYO, RETSU) = ""
　　　　　　　　End If
　　　　　　Next RETSU
　　　　End If
　　 Next GYO
　　　　　
　　 'ウィンドウ枠の固定
　　 .Range("C1").Select
　　 ActiveWindow.FreezePanes = True
　　 .Range("A1").Select
　　
　　''元データ完成
　　'=========================================
　　''データを基にグラフを作成
　　 Set cho = sh_A3.ChartObjects(1) 'コピー元のグラフ
　　 H = .Range("A1:A15").Height 'グラフの高さ
　　 W = .Range("K1:S1").Width 'グラフの幅
　　 k = 0’グラフの数の変数
　　
　　lastRow1 = .Range("A" & Rows.Count).End(xlUp).Row
　　GYO = 2 '開始行
　　　
　　Do While .Cells(GYO, 1).Value <> ""
　　 .Activate
　　
　　'=========================================
　　'質問ごとのデータ範囲を選択
　　　GYO1 = GYO ' ｸﾞﾙｰﾌﾟの先頭行→GYO1
　　　GYO = GYO + 1
　　　　' 次の行から同じｸﾞﾙｰﾌﾟでない行を見つける
　　　　Do While .Cells(GYO, 1).Value <> "合計" '条件を満たしている間処理を繰り返す
　　　　　　GYO = GYO + 1
　　　　Loop
　　　GYO2 = GYO　 ' 同じｸﾞﾙｰﾌﾟの最終行→GYO2
　　　GYO = GYO + 1
　　
　　 lastcol1 = .Cells(GYO1, Columns.Count).End(xlToLeft).Column '最終列を取得
　　　.Range(.Cells(GYO1, 2), .Cells(GYO2, lastcol1 - 1)).Select
　　　　
　　　Set R = Selection
　　　
　　'=========================================
　　'グラフ作成
　　
　　　　cho.Copy
　　　　DoEvents
　　　　.Paste .Range("k17").Offset(k * 17)
　　　　With .ChartObjects(k + 1)
　　　　　 .Chart.SetSourceData Source:=R
　　　　　 .Chart.ChartTitle.Text = R(1).Value
　　　　　 .Height = H
　　　　　 .Width = W
　　　　End With
　　　　k = k + 1
　　Loop

　　'グラフ作成終了
　　'=========================================

　　 G_GYO = .ChartObjects(.ChartObjects.Count).BottomRightCell.Row + 2 'グラフの右下のセルの行
　　
　　 ''結果ひな形をコピー
　　 sh_A4.UsedRange.Copy
　　 .Activate
　　 .Range("K2").Select
　　
　　 Selection.PasteSpecial Paste:=xlPasteAll
　　 'Selection.PasteSpecial Paste:=xlPasteColumnWidths '＜書式（列幅）もコピーします。＞
　　 Application.PrintCommunication = False '//プリンタとの接続を切断
　　 '印刷範囲設定及び横１ページに収める
　　 .PageSetup.PrintArea = .Range(.Cells(1, 10), .Cells(G_GYO, 20)).Address
　　 .PageSetup.Zoom = False
　　 .PageSetup.FitToPagesWide = 1
　　 .PageSetup.FitToPagesTall = False
　　 Application.PrintCommunication = True '//プリンタと再接続
　　End With 'sh_A5
　　
　　Application.DisplayAlerts = True
　　Application.ScreenUpdating = True
　　
　 MsgBox gakko & "分を作成しました", vbInformation

End Sub