| |
▼マナ さん：
何度も申し訳ありません。
追加で質問です。
ご提示のコードを参考に下記のようにコードを書いて実行しています。
当初問題なく動いていたのですが、突然
cho.Copy のところで
「指定したディメンションは、このグラフの種類では無効です。」
のエラーが出るようになりました。（再実行すれば作成されますし、出ないときもあります。）
解消方法がありますでしょうか。ネットで調べましたが、よく分かりませんでした。。
それから、下記のコードでは、まれに応答なしになって落ちるため、
ステータスバーにグラフの個数を表示させ、
何個目のグラフで落ちるのか確認していたら、
どうも最後のグラフが作成されるまでは行くので、
そのあとループがうまく抜けられないのかと。。
コードの問題点等あればご指摘いただけませんでしょうか。
今は
1.結果用シートを学校名で作成
2.結果用シートにクロス集計_割合シートの集計データをコピー
3.基本グラフのグラフをコピーして
4.結果用シートに貼り付け、データソースを変更
※質問数繰り返し
5.結果通知ひな形のデータを結果シートのグラフ上部に貼り付け、完成。
の手順で行っていますが、
うまくいかないのは、手順がよろしくないからでしょうか？？
ネットや本で調べながらいろんなものを組み合わせて
見よう見まねで書いていますので、ご教示いただけるとありがたいです。
よろしくお願いいたします。
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("I10") & "学校"
MsgBox "結果を作成します", vbInformation
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'’学校名シートがないか確認して追加、あれば削除するコードを記述（記載省略）
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
' Selection.HorizontalAlignment = xlCenter
ActiveWindow.Zoom = 80 '＜アクティブシートの表示を80％にします。＞
.Columns("J").ColumnWidth = 2
.Columns("T").ColumnWidth = 1
.Rows("2:200").RowHeight = 15
'ウィンドウ枠の固定
.Range("C1").Select
ActiveWindow.FreezePanes = True
.Range("A1").Select
''元データ完成
'=========================================
''データを基にグラフを作成
Set cho = sh_A3.ChartObjects(1).Duplicate.Parent 'コピー元のグラフを複製
With sh_A5.Range("A1:A20")
cho.Height = .Height
d = .Rows.Count + 2
End With
cho.Width = .Range("K1:S1").Width
cho.Copy ←←ここ
lastRow1 = .Range("A" & Rows.Count).End(xlUp).Row
GYO = 2 '開始行
k = 0 'グラフの個数
Do While .Cells(GYO, 1).Value <> ""
.Activate
Application.StatusBar = " " & k + 1 & "個めのグラフ処理・・"
'=========================================
'質問ごとのデータ範囲を選択
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
'=========================================
DoEvents
DoEvents
DoEvents
DoEvents
.Paste .Range("k17").Offset(k * d)
.ChartObjects(k + 1).Chart.SetSourceData Source:=r
.ChartObjects(k + 1).Chart.ChartTitle.Text = r(1).Value
k = k + 1
Loop
cho.Delete
Application.CutCopyMode = False
Application.StatusBar = False
'グラフ作成終了
'=========================================
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.CutCopyMode = False
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
|
|
あおこ
- 23/6/15(木) 17:56 -
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
