EXCEL2007 VBA グラフサイズ修正バグ?

このQ&Aのポイント
  • EXCEL2007でマクロを使ってグラフのサイズ調整を行う際に、図形にマクロを登録して実行すると、グラフが広がってしまうバグがある。
  • 月度を含むワークブックに対して、指定したグラフ(chart1)を特定のエリアに配置する処理を行う。
  • このバグの原因は特定のエリアへの配置処理が正常に行われないためであり、解決策は不明である。
回答を見る
  • ベストアンサー

EXCEL2007 VBA グラフサイズ修正バグ?

下記のようなグラフのサイズ調整するVBAプログラムをEXCEL2007で動かしました。 VBEで実行すると正常に動作します。 シートに図形を設置し、その図形にマクロを登録して実行すると、 グラフが3画面位広がってしまいます。 図形にマクロ登録してグラフ調整を正常に動かすことはできないのでしょうか? ----------------------------------------------------- 'グラフの再調整を行うサブルーチン Sub chartRerange()  Dim wb As Workbook  Dim strWbName As String  Dim myRng1, myRng2, myRng3 As Range  Dim myChart As Shape  Dim rngTarget As Range      '開いているすべてのワークブックを処理対象とする  For Each wb In Workbooks   strWbName = wb.Name      '「月度」が含まれているならば処理   If InStr(strWbName, "月度") <> 0 Then    Set myRng1 = wb.Worksheets(2)    Set myRng2 = wb.Worksheets(3)        For Each myChart In myRng1.Shapes     'グラフならば     If (TypeOf myChart.OLEFormat.Object Is ChartObject) Then            Select Case myChart.Name       Case "chart1"        Set rngTarget = Range("B24:AG42")      End Select             'グラフを指定したエリアに配置する      With myChart        .Top = rngTarget.Top        .Left = rngTarget.Left        .Width = rngTarget.Width        .Height = rngTarget.Height      End With     End If    Next   End If  Next      MsgBox "処理完了"      Set wb = Nothing   Set myRng1 = Nothing   Set myRng2 = Nothing   Set myChart = Nothing   Set rngTarget = Nothing End Sub

質問者が選んだベストアンサー

  • ベストアンサー
  • end-u
  • ベストアンサー率79% (496/625)
回答No.1

バグかどうかの前に。 提示コードでは >Set rngTarget = Range("B24:AG42") ここでRangeの親Objectが指定されていない為、 標準モジュール上のコードならActiveSheet.Range("B24:AG42")がSetされています。 (たぶんマクロ登録した図形が配置されているシート) それは意図した動作ですか? また、グラフの場合ChartObjectをLoopすれば良いです。 2007では試していませんが Sub test()   Dim wb As Workbook   Dim ch As ChartObject   Dim i As Long   '開いているすべてのワークブックを処理対象とする   For Each wb In Workbooks     '「月度」が含まれているならば処理     If InStr(wb.Name, "月度") <> 0 Then       For i = 2 To 3         With wb.Worksheets(i)           For Each ch In .ChartObjects             If ch.Name = "chart1" Then               With .Range("B24:AG42")                 ch.Top = .Top                 ch.Left = .Left                 ch.Width = .Width                 ch.Height = .Height               End With             End If           Next         End With       Next     End If   Next   MsgBox "処理完了" End Sub 概ねこんな感じかと。

terbush200
質問者

お礼

ありがとうございます。 無事動作しました! グラフのシート指定があいまいだったのが原因だったのですね。 ループの仕方も勉強になりました。 グラフを初めて扱って、困っていたのでとても助かりました。

関連するQ&A

  • エクセルVBAのオートフィルタについて

    いつもお世話になります。 エクセル2007でVBAでオートフィルタを操作したいのですが、 一部うまくいきません。 以下の様なコードを書いて 日付で絞り込みたいのですが、 何も抽出されません。 リストを見てみると、変数はちゃんと入っており OK ボタンを押すとその日付で抽出されます。 何故VBAでの操作では抽出されないのでしょうか。 ご存じの方がおられましたら、よろしくお願いします。 Sub test() Dim mydate As Variant Dim rng3 As Range Dim fmt As Variant Dim objList3 As ListObject Dim wb1 As Workbook Dim wb2 As Workbook Dim wb4 As Workbook Dim sh1 As Worksheet Dim sh2 As Worksheet Dim sh3 As Worksheet Dim sh4 As Worksheet Dim sh7 As Worksheet '----------------------------------------------------------------------- Set wb1 = Workbooks("301.xlsm") Set wb2 = Workbooks("1.xls") Set wb4 = Workbooks("2.xls") Set sh1 = wb1.Worksheets("@") Set sh2 = wb1.Worksheets("@@") Set sh3 = wb2.Worksheets("@@@") Set sh4 = wb2.Worksheets("@@@@") Set sh7 = wb4.Worksheets("@@@@@") '---------------------------------------------------------- sh2.Range("A1:z63").ClearContents With sh7 Set objList3 = .ListObjects("リスト1") fmt = .Range("A2").NumberFormatLocal mydate = Format(mydate, fmt) objList3.Range.AutoFilter Field:=7, Criteria1:=mydate objList3.Range.AutoFilter Field:=5, Criteria1:="test" Set rng3 = objList3.Range.SpecialCells(xlCellTypeVisible) rng3.Copy sh2.Range("A2") objList3.Range.AutoFilter Field:=5 objList3.Range.AutoFilter Field:=5, Criteria1:=">=190" Set rng3 = objList3.Range.SpecialCells(xlCellTypeVisible) rng3.Copy sh2.Range("A20") objList3.Range.AutoFilter Field:=5 objList3.Range.AutoFilter Field:=7 End With Application.CutCopyMode = False Set rng3 = Nothing Set fmt = Nothing Set objList3 = Nothing Set wb1 = Nothing Set wb2 = Nothing Set wb4 = Nothing Set sh1 = Nothing Set sh2 = Nothing Set sh3 = Nothing Set sh4 = Nothing Set sh7 = Nothing End Sub (一部省略しています)

  • VBA オートフィルタで抽出したものを連続貼り付け

    下記のように情報が100近くまで存在した場合に、オートフィルターで一つずつ抽出したものをコピーし、新規シートに貼り付けたいのですが、どうすれば良いのでしょうか? 1 1 1 2 2 2 3 3 3 たとえばシート1に 1 1 1     シート2に 2 2 2 といったように処理したいので、教えて下さい。 vbaの参考書とサンプルを見て下記のように作成したのですが上手くいきません。 どんな本を読めば作成出来るようになるのかわからず、質問させていただきました。 ub オートフィルター() Dim myRng As Range Dim mySht As Worksheet Set myRng = _ Worksheets(1).Range("A1").CurrentRegion With Worksheets Set mySht = .Add(after:=.Item(.Count)) End With With myRng .AutoFilter field:=1, Criteria1:=8 On Error Resume Next .Resize(.Rows.Count - 1).Offset(1).Copy mySht.Range("A1") .SpecialCells(xlCellTypeVisible).Copy mySht.Range("A1").AutoFilter mySht.Range("A1").AutoFilter If Err.Number <> 0 Then Application.DisplayAlerts = False mySht.Delete Application.DisplayAlerts = True End If On Error GoTo 0 End With Set myRng = Nothing Set mySht = Nothing End Sub

  • VBAの繰りかえし処理について

    workbook1(以下wb1)のB3に入力した県名を含む行を、 workbook2から取り出し、wb1のB7以降に表示させたいと思っています (ちなみに県名はwb2のC列に入っています) 同じ県名が含まれる行が多いので、それらを繰り返し処理で 全て書き出したいと思い、以下のマクロを作りました。 Sub macro3() Dim c Dim wb1 As Workbook Dim wb2 As Workbook Dim k As Integer Dim firstAddress As String Application.ScreenUpdating = False Set wb1 = ActiveWorkbook Set wb2 = Workbooks.Open("G:\zyouhousyori\inn100best_full.csv") Set c = cell.Find(What:=Range("B3").Value) With wb2.Worksheets(1).Range("A1:A100") If Not c Is Nothing Then firstAddress = c.Address Do Set c = cell.FindNext(c) For k = 0 To 10 .Range("C100").End(xlUp).Offset(1).Copy _ wb1.Worksheets("sheet1").Cells(7 + k, 2) Exit For ★Loop While Not c Is Nothing And _ c.Address <> firstAddress End If End With Application.ScreenUpdating = True wb2.Close False End Sub しかし、実行すると★マークのついた所でエラーになってしまいます (対応するDoがありません、と出ます) VBA初心者なので、どこがどう違うのかいまいちわかりません; アドバイスお願いします。

  • エクセルVBA フォルダ内のどんなシート名であっても読み込みたい

    フォルダ内の別ブック(D3で指定)の「情報」シートを読み込んで対象年月日に該当するデータを抽出して別ブックに貼り付けるものなんですが、下のコードではSet ws = wb.Worksheets("情報")と、なっていて、限定しているのですが、これをD3のファイルのどんなシート名であっても読み込みたいのですが、どのようにコードにしたらいいでしょうか?D3で指定するブックには必ずひとつのシートしかありません。 よろしくお願いします。 Sub test_1() Dim wb As Workbook Dim ws As Worksheet Dim ms As Worksheet Dim nb As Workbook Dim r As Long Set ms = ThisWorkbook.Worksheets("メニュー") Set wb = Workbooks.Open(ms.Parent.Path & "\" & ms.Range("D3").Value) Set ws = wb.Worksheets("情報") Set nb = Workbooks.Add With ws .Range("Q1").AutoFilter _ Field:=17, _ Criteria1:=">=" & ms.Range("D5").Text, _ Operator:=xlAnd, _ Criteria2:="<=" & ms.Range("F5").Text With .AutoFilter.Range r = .Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count If r = 1 Then MsgBox "抽出対象データ無し。" wb.Close False nb.Close False Set wb = Nothing: Set ws = Nothing Set ms = Nothing: Set nb = Nothing Exit Sub End If .Copy End With End With With nb.Worksheets(1) .Paste With .Range("A1:AG1") .Interior.ColorIndex = 6 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With End sub

  • 図形のクリアで入力規則の▼が消える

     図形のクリアでG1の入力規則の▼まで一時的に消えてしまいます。コード文でShapesを 用いているのではないかと思いますが、▼で消去を回避する方法が ありましたらお教え願え ますでしょうか? Windows7・SP1 Office2010 Sub 図形のクリア() Dim myRng As Range Dim sp As Variant Set myRng = Range("I10:CW60") For Each sp In ActiveSheet.Shapes If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then On Error Resume Next sp.Delete End If Next Set myRng = Nothing End Sub

  • VBAでオートフィルを使って指定する文字列を含むものを表示させたい

    VBAを使って、セルD1に入力した文字列を検索するマクロを作りたいと思っています。 私は初心者で前に似たようなものを作ってもらって それを加工しようとしたのですが、うまくいきませんでした。 以前は完全に一致するもので表示でしたが、 今回は含むものを表示させたいです。 ワイルドカードは*をつけるのはわかるのですが、 いろいろやってみましたがダメでした。(単純なことかもしれないですけど) Private Sub Worksheet_Change(ByVal Target As Range) Dim myRng1 As Range Dim myRng2 As Range Set myRng1 = Target.Cells(1) If Application.Intersect(myRng1, Range("D1")) Is Nothing Then Exit Sub Set myRng2 = Range("D1").CurrentRegion With myRng2 If myRng1 = "" Then ActiveSheet.ShowAllData Else .AutoFilter Field:=4, Criteria1:=myRng1.Value End If End With End Sub

  • 【VBA】複数のブックを1つのシートにまとめる

    あるフォルダ内に複数のブックが入っており、新しいブックに1シートでまとめようとしております。 フィルターを使用すればよいのかもしれませんが、マクロを使用したいです。 (1)全て同じフォーマットである (2)全てA17から数値が入力されているので、16行目まではフォーマットを残し、A17行目以降K列までをコピーして結合したい Sub 結合() '結合したいファイルがあるフォルダの場所 cドライブなら "C:\test\" Const Fol As String = "C:\test\" Dim Fn Dim NewFile As Workbook Dim Wb As Workbook Dim Ws1 As Worksheet Dim R As Range Set NewFile = Workbooks.Add Set Ws1 = NewFile.Worksheets(1) Set R = Ws1.Range("A17") Fn = Dir(Fol, vbNormal) Do Until Fn = "" Set Wb = Workbooks.Open(Fol & Fn) 'ワークシート1をコピーする場合は Wb.Worksheets(1) Set Ws1 = Wb.Worksheets(1) 'タイトル行を設定 If ck = False Then For cnt = 1 To 4 Wb.Worksheets(cnt).Range("A1:J16").Copy Destination:=NewFile.Worksheets(cnt).Range("A1") Next cnt ck = True End If For cnt = 1 To 4 Set Ws1 = NewFile.Worksheets(cnt) Set Ws2 = Wb.Worksheets(cnt) R = Ws1.Cells(Rows.Count, 1).End(xlUp).Row + 1 With Ws2 End With Next 'A17行目からコピーして結合する(→本当はA17行目~K列までを反映したい) Ws2.Range("A17", Ws2.Cells(Rows.Count, 3).End(xlUp)).Resize(, 20).Copy R If R.Offset(1).Value = "" Then Set R = R.Offset(1) Else Set R = R.End(xlDown).Offset(1) End If Wb.Close 'Debug.Print Fn Fn = Dir Loop Set R = Nothing Set Ws1 = Nothing: Set Ws2 = Nothing Set Wb = Nothing: Set NewFile = Nothing End Sub マクロは触ったことない初心者でグーグル検索をしながら作ってみました。 一応実行するとエラーは出ないのですが、結合されたリストが飛び飛びで、理由がわかりません。 どなたかおわかりになりますでしょうか・・・。

  • エクセルVBAでつまずいています

    教えてください。以前別のブックから、抽出条件を指定して、 項目を追加して、ある条件を検査して、それによって追加した項目の列 に対応する値を書き込むというコードを教えていただきました。 質問は、今現在、 With .Range("AH2").Resize(r - 1, 1) .FormulaR1C1 = _ "=IF(RC[-25]=""AAA"",""aaa""," & _ "IF(RC[-25]=""BBB"",""bbb""," & _ "IF(RC[-25]=""CCC"",""ccc""," & _ "IF(RC[-25]=""DDD"",""ddd"",""xxx"") の部分で、関数を設定していますが、AIの列にも同じように関数 (VLOOKUP)を設定したいのですが、Resize(r - 1, 1)の意味するところが しっかり理解していないためできません。 A1形式ですが、例えば、 参照先がD2、A2:J100として =VLOOKUP(D2,A2:J100,5,FASE) =VLOOKUP(D2,A2:J100,6,FASE) =VLOOKUP(D2,A2:J100,7,FASE) という条件を追加したいのですが、わかりませんでした。 どのようにしたらいいでしょうか。よろしくお願いします。 Sub test() Dim wb As Workbook Dim ws As Worksheet Dim ms As Worksheet Dim nb As Workbook Dim r As Long Set ms = ThisWorkbook.Worksheets("条件入力") Set wb = Workbooks.Open(ms.Parent.Path & "\" & ms.Range("D3").Value) Set ws = wb.Worksheets("元データ") Set nb = Workbooks.Add With ws .Range("Q1").AutoFilter _ Field:=17, _ Criteria1:=">=" & ms.Range("D5").Text, _ Operator:=xlAnd, _ Criteria2:="<=" & ms.Range("F5").Text With .AutoFilter.Range r = .Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count If r = 1 Then MsgBox "抽出対象データ無し。" wb.Close False nb.Close False Set wb = Nothing: Set ws = Nothing Set ms = Nothing: Set nb = Nothing Exit Sub End If .Copy End With End With With nb.Worksheets(1) .Paste With .Range("A1:AG1") .Interior.ColorIndex = 6 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With .Range("AH1").Value = "追加項目A" .Range("AI1").Value = "追加項目B" .Range("AJ1").Value = "追加項目C" .Range("AK1").Value = "追加項目D" With .Range("AH2").Resize(r - 1, 1) .FormulaR1C1 = _ "=IF(RC[-25]=""AAA"",""aaa""," & _ "IF(RC[-25]=""BBB"",""bbb""," & _ "IF(RC[-25]=""CCC"",""ccc""," & _ "IF(RC[-25]=""DDD"",""ddd"",""xxx"") End With End With nb.SaveAs _ Filename:=ms.Parent.Path & "\" & _ Replace(wb.Name, ".xls", "") & "更新データ.xls" wb.Close False nb.Close Set wb = Nothing: Set ws = Nothing Set ms = Nothing: Set nb = Nothing End With End Sub

  • VBAが止まります。

    フォルダ内の全てのエクセルデータを一つにまとめたいのですが、 下記を実行すると、添付ファイルのメッセージが出て先に進みません。 調べましたがよくわかりませんので、ご教示いただけませんでしょうか。 画像の最上部の『'プログラム0|変数設定の指定Option Explicit』が欄外に はみだしていて直せません、こちらが原因でしょうか。 ------------------------------------------------------- 'プログラム1|プログラム開始 Sub GetExcelDataInFolder() 'プログラム2|シート設定 Dim ws1 As Worksheet Set ws1 = ThisWorkbook.Worksheets("Sheet1") 'プログラム3|FileSystemObjectの設定 Dim fs As FileSystemObject Set fs = New FileSystemObject 'プログラム4|対象フォルダを取得 Dim myfolder As Folder Set myfolder = fs.GetFolder(ThisWorkbook.Path) 'プログラム5|対象フォルダ内の全ファイルを処理 Dim myfile As File For Each myfile In myfolder.Files 'プログラム6|拡張子が「xlsx」のファイルのみを処理 If fs.GetExtensionName(myfile) = "xlsx" Then 'プログラム7|フォルダ内のエクセルを開いてシートを設定 Dim wb As Workbook Set wb = Workbooks.Open(Filename:=myfile) Dim ws2 As Worksheet Set ws2 = wb.Worksheets(1) 'プログラム8|開いたエクセルの最終行を取得 Dim cmax As Long cmax = ws2.Range("A65536").End(xlUp).Row Debug.Print myfile.Name & "のcmax=" & cmax 'プログラム9|開いたエクセルのデータを転記 Dim i As Long For i = 2 To cmax Dim cmax1 As Long cmax1 = ws1.Range("A65536").End(xlUp).Row ws1.Range("A" & cmax1 + 1 & ":E" & cmax1 + 1).Value = ws2.Range("A" & i & ":E" & i).Value Next 'プログラム10|エクセルを閉じる wb.Close 'プログラム11|オブジェクト解放 Set ws2 = Nothing Set wb = Nothing End If Next 'プログラム12|エクセルを保存 ThisWorkbook.Save 'プログラム13|オブジェクト解放 Set myfolder = Nothing Set fs = Nothing 'プログラム14|プログラム終了

  • VBAがとまります。

    フォルダ内の全てのエクセルデータを一つにまとめたいのですが、 下記を実行すると、『実行時エラー1004 アプリケーション定義またはオブジェクト定義のエラーです。』のメッセージが出て先に進みません。対象のデータを開いて実行しても同様でした。 調べましたがよくわかりませんので、ご教示いただけませんでしょうか。 基本的なところかもしれませんが、よくわかりません。 どうぞよろしくお願いいたします。 ------------------------------------------------------- 'プログラム1|プログラム開始 Sub GetExcelDataInFolder() 'プログラム2|シート設定 Dim ws1 As Worksheet Set ws1 = ThisWorkbook.Worksheets("Sheet1") 'プログラム3|FileSystemObjectの設定 Dim fs As FileSystemObject Set fs = New FileSystemObject 'プログラム4|対象フォルダを取得 Dim myfolder As Folder Set myfolder = fs.GetFolder(ThisWorkbook.Path) 'プログラム5|対象フォルダ内の全ファイルを処理 Dim myfile As File For Each myfile In myfolder.Files 'プログラム6|拡張子が「xlsx」のファイルのみを処理 If fs.GetExtensionName(myfile) = "xlsx" Then 'プログラム7|フォルダ内のエクセルを開いてシートを設定 Dim wb As Workbook Set wb = Workbooks.Open(Filename:=myfile) Dim ws2 As Worksheet Set ws2 = wb.Worksheets(1) 'プログラム8|開いたエクセルの最終行を取得 Dim cmax As Long cmax = ws2.Range("A65536").End(xlUp).Row Debug.Print myfile.Name & "のcmax=" & cmax 'プログラム9|開いたエクセルのデータを転記 Dim i As Long For i = 2 To cmax Dim cmax1 As Long cmax1 = ws1.Range("A65536").End(xlUp).Row ws1.Range("A" & cmax1 + 1 & ":E" & cmax1 + 1).Value = ws2.Range("A" & i & ":E" & i).Value Next 'プログラム10|エクセルを閉じる wb.Close 'プログラム11|オブジェクト解放 Set ws2 = Nothing Set wb = Nothing End If Next 'プログラム12|エクセルを保存 ThisWorkbook.Save 'プログラム13|オブジェクト解放 Set myfolder = Nothing Set fs = Nothing 'プログラム14|プログラム終了

専門家に質問してみよう