| |
いつも参考にさせていただきありがとうございます。
アンケートの集計結果を作成するマクロを組んでいます。
「クロス集計_割合」に、質問ごとにすべての学校分の集計があり、
指定した学校分のデータを抽出し、あらかじめ作成したグラフをコピーし、
「結果ひな形」の通知様式と組み合わせて作成しています。
指定校分のデータ抽出は、「クロス集計_割合」を複写後、指定校以外のデータ行を削除し行っています。
データ作成後、質問ごとに順に範囲を選択し「基本グラフ」にあるグラフをコピーし、データソースを変更し作成しています。
今回のアンケートは９問あるため、グラフは１シートに９個コピーされます。
下のようにコードを書いていますが、ブレークポイントを入れて少しずつ実行した場合、きちんと作成されるのですが、一気に処理すると、時々固まって落ちます。（3〜4回に1回応答なしになって落ちます。）
下記のうち、グラフをコピーする部分を丸ごと削除すると、数回試しても落ちることはなかったので、グラフのコピー箇所に問題があるのだろうと思いますが、改善方法がよくわかりません。
ご指摘、もしくはヒントでもいただけると幸いです。
よろしくお願いいたします。
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("結果ひな形")
gakko = sh_A1.Range("I14")
MsgBox gakko & "分の結果を作成します", vbInformation
Application.DisplayAlerts = False
Application.ScreenUpdating = False
gakko = Left(gakko, InStr(gakko, "中"))
'’学校名シートがないか確認して追加、あれば削除するコードを記述（記載省略）
‘追加したシート名をgakkoに変更するコードを記述（記載省略）
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
‘学校名からコード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
'0値クリア
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
''ここまででグラフ元データ完成
'=========================================
''データを基にグラフを作成
lastRow1 = .Range("A" & Rows.Count).End(xlUp).Row
GYO = 2 '開始行
G = 0
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
G = G + 1 '設問数をカウント
lastcol1 = .Cells(GYO1, Columns.Count).End(xlToLeft).Column '読み込み行の最終列を取得
.Range(.Cells(GYO1, 2), .Cells(GYO2, lastcol1 - 1)).Select
Set R = Selection.Item(1)
Set S = Selection
'=========================================
If G = 1 Then '１つめのグラフの位置（行）
G_GYO = 17
Else
G_GYO = .ChartObjects(.ChartObjects.Count).BottomRightCell.Row + 2 'グラフの右下のセルの行
End If
'sh_A3.ChartObjects(1).Copy.Range ("A1")
sh_A3.ChartObjects(1).Copy
DoEvents
.Activate
.Range("A1").Select
.Paste
Application.CutCopyMode = False
.ChartObjects(.ChartObjects.Count).Left = .Range("K" & G_GYO).Left
.ChartObjects(.ChartObjects.Count).Top = .Range("K" & G_GYO).Top
.ChartObjects(.ChartObjects.Count).Chart.SetSourceData Source:=S '選択範囲をデータソースに
.ChartObjects(.ChartObjects.Count).Chart.ChartTitle.Text = R.Value
.ChartObjects(.ChartObjects.Count).Height = .Range("A1:A15").Height
.ChartObjects(.ChartObjects.Count).Width = .Range("K1:S1").Width
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}
