| |
▼マナ さん：
>▼あおこ さん：
>
>こんな感じで書き直すとどうなりますか？
>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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
