指定範囲の図形を削除するマクロ
- エクセルの指定範囲にある図形を削除するマクロの使い方について説明します。
- マクロを実行すると、指定した範囲のセルにある全ての図形が削除されます。
- アクティブセルを指定範囲にする方法を試しましたが、うまくいかないようです。
- ベストアンサー
指定範囲をアクティブセルに変更(エクセル)
以下のマクロで、A1:E20にある全ての図形を削除できます。 Sub test() Dim wLeft As Long Dim wTop As Long Dim wRight As Long Dim wBottom As Long Dim s As Object With Range("A1:E20") wTop = .Top wLeft = .Left wBottom = .Top + .Height wRight = .Left + .Width End With For Each s In ActiveSheet.DrawingObjects With s If wTop <= .Top And _ wLeft <= .Left And _ wBottom >= .Top + .Height And _ wRight >= .Left + .Width Then .Delete End If End With Next End Sub "With Range("A1:E20")"を、任意のアクティブセルに変更するにはどうすればいいでしょうか？ ちなみに、"With ActiveCell"や"With Range(ActiveCell.Address)"では、うまくいきませんでした。
- kayonon
- お礼率100% (22/22)
- オフィス系ソフト
- 回答数1
- ありがとう数2
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
With ActiveWindow.RangeSelection とか、 With Range(ActiveWindow.RangeSelection.Address ) http://www.k1simplify.com/vba/tipsleaf/leaf15.html http://www.officetanaka.net/excel/vba/cell/cell10.htm
関連するQ&A
- 図形消去後に文字入力(エクセル）
Sub test() Dim c As Range If Not TypeName(Selection) = "Range" Then Exit Sub For Each c In Selection With c.MergeArea wTop = .Top wLeft = .Left wBottom = .Top + .Height wRight = .Left + .Width End With For Each s In ActiveSheet.DrawingObjects With s If wTop <= .Top And _ wLeft <= .Left And _ wBottom >= .Top + .Height And _ wRight >= .Left + .Width Then .Delete End If End With Next Next End Sub 上記マクロは、選択状態になっている個々のセルの中に、すっぽり収まる状態で存在しているオブジェクトを消去します。 オブジェクトが消去されたセルに、"○"が入力されるようにしたいのですが。 どういった記述が必要になるでしょうか？
- ベストアンサー
- オフィス系ソフト
- Excel VBA チェックボックスの判断
下記のようなマクロでチェックボックスを作成したのですが、その作成したチェックボックスをクリックしたときに、ある処理を実行させるようにするにはどうすればいいのでしょうか？ よろしくお願いします。 Dim Max as Long Dim Cell as Range Dim Check as CheckBox ・ ・ ・ For i = 0 To Max With Cell.Offset(i) Set Check = ActiveSheet.CheckBoxes.Add_ (Left:=.Left,Top:=.Top, Width:=.Width, Height:=.Height) End With With Check .LinkedCell = Cell.Address .Caption = "" .Value = False End With Next
- ベストアンサー
- オフィス系ソフト
- グラフのデータ範囲をCellsで指定するとエラー
あるサイトを参考に、ＶＢＡでChartType が xlStockOHLC 形式のグラフを作成しようとしています。 ところがデータ範囲の指定方法で .SetSourceData Source:=wsdata1.Range("b1:e100"), PlotBy:=xlColumns あるいは i = 100 .SetSourceData Source:=wsdata1.Range("b1:e" & i), PlotBy:=xlColumns とすれば、正常に動作しますが、 .SetSourceData Source:=wsdata1.Range(Cells(1, 2), Cells(100, 5)), PlotBy:=xlColumns とすると、Rangeメソッドは失敗しました。_worksheetオブジェクト となります。 両者は同じ範囲を指定しているつもりなのですが、どこが間違いでしょうか。 Option Explicit Sub sample() Dim ws As Worksheet Dim wsdata0, wsdata1 As Worksheet Dim topPosition As Double Dim leftPosition As Double Dim width As Double Dim height As Double Dim chartObj As ChartObject Dim chart0, chart1 As chart Dim i As Integer 'グラフを作成するシートを指定 Set ws = Worksheets("Sheet1") Set wsdata0 = Worksheets("saya00") Set wsdata1 = Worksheets("saya01") 'グラフを表示させる位置を取得 ※例としてセル「G2」の位置を取得 With ws.Range("a1") leftPosition = .Left topPosition = .Top End With 'グラフの横と縦のサイズを設定 width = 1000 height = 500 'ChartObjectオブジェクトを作成 Set chartObj = ws.ChartObjects.Add(leftPosition, topPosition, width, height) 'ChartObjectオブジェクトの名前を設定 chartObj.Name = "saya" 'Chartオブジェクト(グラフ)を作成 Set chart0 = chartObj.chart With chart0 'グラフの作成元としてセル「B2」から一覧の範囲を指定 ' .SetSourceData Source:=wsdata.Range("b1:e100"), PlotBy:=xlColumns ' .SetSourceData Source:=ws.Range("b1:e100"), PlotBy:=xlColumns ' i = 100 ' .SetSourceData Source:=wsdata1.Range("b1:e" & i), PlotBy:=xlColumns .SetSourceData Source:=wsdata1.Range(Cells(1, 2), Cells(10, 5)), PlotBy:=xlColumns 'グラフの種類を「折れ線グラフ」に指定 .ChartType = xlStockOHLC 'グラフのタイトルを表示 .HasTitle = True 'グラフのタイトルを設定 .ChartTitle.Text = "saya-1" 'グラフのタイトルのフォントサイズを設定 .ChartTitle.Font.Size = "12" End With '後片付け Set chart0 = Nothing Set chart1 = Nothing Set chartObj = Nothing End Sub
- ベストアンサー
- Visual Basic
- 画像をトリミングして（上書き）保存
以下のコードで最終的に編集したImgを保存していますが Img.SaveFile outFile 同名ファイルがある場合は、エラーがでます。 エラー無く上書き保存するにはどのようにコードを編集すれば良いですか？ Sub TrimImg() Dim folderPath As String Dim fso As Object Dim folder As Object Dim files As Object Dim file As Object Dim Img As Object Dim flag As Long folderPath = "C:\Users\TAC_\download\Yes\YES - Open your eyes - FULL ALBUM\" Set fso = CreateObject("Scripting.FileSystemObject") Set folder = fso.GetFolder(folderPath) For Each file In folder.files If LCase(right(file.Name, 4)) = ".jpg" Or LCase(right(file.Name, 5)) = ".jpeg" Then flag = left(file.Name, 1) Set Img = CreateObject("WIA.ImageFile") Img.LoadFile file.Path Dim inputFile As String Dim outputFile As String 'Dim Img As Object 'As ImageFile Dim IP 'As ImageProcess Set Img = CreateObject("WIA.ImageFile") Set IP = CreateObject("WIA.ImageProcess") Select Case flag Case 1 inputFile = file.Path outputFile = folderPath & fso.GetBaseName(file.Name) & "(new)." & fso.GetExtensionName(file.Name) Img.LoadFile inputFile Dim imageWidth As Long Dim imageHeight As Long imageWidth = Img.width imageHeight = Img.height Dim left1 As Long Dim top1 As Long Dim right1 As Long Dim bottom1 As Long left1 = 0.2 * imageWidth top1 = 0 right1 = 0.2 * imageWidth bottom1 = 0 ModImage inputFile, outputFile, left1, top1, right1, bottom1 ' End Select End If Next file MsgBox "トリミングが完了しました。" End Sub Function ModImage(inFile As String, outFile As String, left As Long, top As Long, right As Long, bottom As Long) Dim Img As Object, IP As Object Set IP = CreateObject("WIA.ImageProcess") 'create WIA objects Set Img = CreateObject("WIA.ImageFile") Img.LoadFile inFile 'load image IP.Filters.Add IP.FilterInfos("Crop").FilterID 'setup filter With IP.Filters(1) .Properties("Left") = left .Properties("Top") = top .Properties("Right") = right .Properties("Bottom") = bottom End With Set Img = IP.Apply(Img) 'apply change '------------------------------------ ' 再整形 ' Dim imageWidth As Long ' Dim imageHeight As Long ' ' imageWidth = Img.width ' imageHeight = Img.height Dim NewWidth As Long Dim NewHeight As Long NewWidth = (Img.height + Img.width) / 2 NewHeight = (Img.height + Img.width) / 2 With CreateObject("WIA.ImageProcess") .Filters.Add .FilterInfos("Scale").FilterID .Filters(1).Properties("MaximumWidth") = NewWidth .Filters(1).Properties("MaximumHeight") = NewHeight .Filters(1).Properties("PreserveAspectRatio") = False Set Img = .Apply(Img) End With Img.SaveFile outFile End Function
- ベストアンサー
- Excel（エクセル）
- エクセル2007のマクロについて
B9に品番を入力するとA9に画像が自動挿入される所まではなんとか出来たのですが、 同じくB10,B11,B12・・・と下の行にも同じように品番を入力すれば画像が自動挿入される様にするには,どうのようにすれば良いのでしょうか？宜しくお願い致します。 A B 9 画像 品番 10 画像 品番 11 画像 品番 12 画像 品番 ・ ・ ・ Private Sub Worksheet_Change(ByVal Target As Range) Const ImagePath = "C:\Users\f\Desktop\画像\" If Intersect(Target, Range("B9")) Is Nothing Then Exit Sub Application.EnableEvents = False Dim codRange As Range Set codeRange = Range("B9") Dim picRange As Range Set picRange = Range("A9") Dim objPic As Picture For Each objPic In ActiveSheet.Pictures If objPic.Left >= picRange.Left And objPic.Left <= picRange.Left + picRange.Width _ And objPic.Top >= picRange.Top And objPic.Top <= picRange.Top + picRange.Height Then objPic.Delete Exit For End If Next picPath = ImagePath & codeRange.Value & ".jpg" If Dir(picPath, vbNormal) = "" Then picRange.Cells(1, 1).Value = "画像がありません" Else picRange.Select Sheets(1).Pictures.Insert(picPath).Select '画像ファイルの挿入 With ActiveSheet.Pictures(ActiveSheet.Pictures.Count).ShapeRange .LockAspectRatio = msoFalse .Parent.Visible = msoTrue .Left = picRange.Left .Top = picRange.Top .Height = picRange.Height .Width = picRange.Width End With picRange.Cells(1, 1).Value = "" End If Application.EnableEvents = True End Sub
- 締切済み
- オフィス系ソフト
- マクロでセルに入れたファイル名の画像を隣のセルに読
みこむ。 マクロで「セルに入れたファイル名の画像を隣のセルに読み込む」作業をVBA でつくりました。 そのファイル名がないときは、飛ばすようにできないでしょうか。 「 Set myPic = ActiveSheet.Pictures.Insert(sCurDir & myCell.Value & ".JPG")」 ここでとめられてしまいます。 A(No） B(名) C(画像) --------------------------------------------- 1 1 test01 D:\画像\teet01.JPG 2 2 test02 D:\画像\teet02.JPG 3 3 test03 D:\画像\teet03.JPG Private Sub CommandButton1_Click() Dim i As Long Dim myPic As Object Dim myCell As Range Dim sCurDir As String sCurDir = ThisWorkbook.Path & "\画像\" For i = 6 To Range("B" & ActiveSheet.Rows.Count).End(xlUp).Row Step 6 Set myCell = Range("B" & i) Set myPic = ActiveSheet.Pictures.Insert(sCurDir & myCell.Value & ".JPG") With myPic .Left = Range("C" & i).Left .Top = Range("C" & i).Top .Width = Range("C" & i).MergeArea.Width .Height = Range("C" & i).MergeArea.Height End With Set myPic = Nothing Next i End Sub
- ベストアンサー
- オフィス系ソフト
- エクセル マクロ
エクセルのある特定のセルをダブルクリックすると 画像ファイルを参照しにいき 貼りつけたい画像ファイル選ぶと そのセルの大きさに合わせて 画像ファイルがそのセルに 貼りつくというマクロが以下の通りなんですが Excel2003からExcel2007へ変更すると 画像ファイルの貼りつく位置がダブルクリックしたセルではない所に 貼りつくようになりました 参照や大きさなどはちゃんと機能しているようです どこを変更すればよいでしょうか？ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, Range('特定のセル)) Is Nothing Then Exit Sub Cancel = True Dim myPic Dim myRange As Range Dim rX As Double, rY As Double myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif") If VarType(myPic) = vbBoolean Then Exit Sub Set myRange = Target Application.ScreenUpdating = False With ActiveSheet.Pictures.Insert(myPic).ShapeRange rX = myRange.Width / .Width rY = myRange.Height / .Height If rX > rY Then .Height = .Height * rY Else .Width = .Width * rX End If .Left = .Left + (myRange.Width - .Width) / 2 .Top = .Top + (myRange.Height - .Height) / 2 End With Application.ScreenUpdating = True Cancel = True End Sub
- ベストアンサー
- オフィス系ソフト
- VBAで特定の文字が含まれている画像ファイル
下記コードで画像の貼り付けを行っていますが 現在は適当な順番で貼り付けが行われます。 Declare Function SetCurrentDirectory Lib "kernel32" Alias _ "SetCurrentDirectoryA" (ByVal CurrentDir As String) As Long Sub ShapeLoadtest() Dim Fname As Variant, fe As Variant Dim Fn As Variant, Pic As Shape Dim pno As Long Dim myFileName As String Dim strFileName As String Range("B4").Select SetCurrentDirectory "C:\Users\yuya\Desktop\画像\" Fname = Application.GetOpenFilename _ (",*", MultiSelect:=True) If Not IsArray(Fname) Then MsgBox "取り消されました。", vbInformation Exit Sub End If Application.ScreenUpdating = False pno = 0 For Each Fn In Fname 'この次へ追加すべき行 Selection.Offset(-1, 0) = Mid(Fn, InStrRev(Fn, "\") + 1, Len(Fn) - InStrRev(Fn, "\")) ActiveCell.Select Set Pic = ActiveSheet.Shapes.AddPicture(Filename:=Fn, _ LinkToFile:=False, _ SaveWithDocument:=True, _ Left:=0, Top:=0, Width:=0, Height:=0) With Pic .ScaleWidth 1, msoTrue .ScaleHeight 1, msoTrue .Top = ActiveCell.Top ' 位置：アクティブセルの上側に重ねる .Left = ActiveCell.Left ' 位置：アクティブセルの左側に重ねる .Placement = xlMove ' 移動するがサイズ変更しない End With If ActiveCell.Column = 2 Then ActiveCell.Offset(, 8).Select ElseIf ActiveCell.Column = 10 Then ActiveCell.Offset(, 8).Select ElseIf ActiveCell.Column = 18 Then ActiveCell.Offset(32, -16).Select End If Set Pic = Nothing pno = pno + 1 Next Application.ScreenUpdating = True Range("A1").Select MsgBox pno & "枚の画像を挿入しました", vbInformation End Sub これを画像ファイル名に【あいう】という文字が混じっていたら If ActiveCell.Column = 2 Then ActiveCell.Offset(, 8).Select のセルに 【１２３】という数字が混じっていたら ElseIf ActiveCell.Column = 10 Then ActiveCell.Offset(, 8).Select のセルに貼り付けという具合にしたいです。 よろしくお願いします。
- ベストアンサー
- Excel（エクセル）
- Excel VBA でグラフタイトルの位置変更
Excelで作成したグラフのタイトルの、（左の位置や幅は文字数で違ってくるので、）TopとHeightを、VBAを使って変更しようと思っています。 それで、以下のようなコードを書いてみたのですが、 「引数の数が一致しません または不正なプロパティを使用しています」 とのエラーメッセージが出てしまい、実行できません。 ChartTitle.Left などの引数の型はDoubleのようなので、 ' Dim T, L, H, W As Double としてみましたが、変化はありません。 Sub ChangeChartTitlePos() 'Excel VBA でグラフタイトルの位置変更 ' Dim T, L, H, W As Double T = 2: L = 68.4: H = 26.4: W = 220 With ActiveChart.ChartTitle .Top = T .Height = H ' .Left = L ' .Width = W End With End Sub どなたか解決方法をご教授頂ければ幸いです。 また、VBAを使わずにグラフのタイトルのTopとHeightを任意の値に変更する方法がありましたら、その方法も教えて頂ければと存じます。 よろしくお願いします。 追記 ちなみに、プロットエリアの変更は、以下のコードで処理できています。 Sub ChangePlotArea() With ActiveChart.PlotArea .Top = 36.4 .Left = 7 .Height = 190.6 .Width = 274.5 End With End Sub
- ベストアンサー
- その他MS Office製品
- VBA ユーザーフォーム
VBAにおけるユーザーフォームの件 今，下記の様なプログラムを組んでいるのですが，「myComboBox」に入った？値をこの後で使用したいのですが， どうすればいいのかわからなくて困っています． これで何がしたいかというと，ある個数分のコンボボックスを自動で作成して使用しようとしているのです． Private Sub UserForm_Initialize() Dim a As String Dim jj As Long Dim s As Integer Dim myComboBox As Control N = InputBox("抜き出したいデータ数は？") EffectiveRow = Range("A65536").End(xlUp).Row Effectivecolumn = Cells(2, 16384).End(xlToLeft).Column For s = 1 To N Set myComboBox = Me.Controls.Add("Forms.ComboBox.1") With myComboBox .Height = 20 .Width = 150 .Left = 120 .Top = (s - 1) * .Height + 10 End With For jj = 1 To Effectivecolumn myComboBox.AddItem Worksheets(1).Cells(1, jj).Value Next jj a = myComboBox.Value Worksheets(2).Cells(1, 1) = a Next s End Sub
- ベストアンサー
- オフィス系ソフト
お礼
うまくいきました。 有難うございました。