エクセルマクロで全シートに図の挿入をする方法
- エクセルマクロを使用して、請求書の全シートに角印を押す方法について教えてください。
- 現在、1シート目の名前を'FACE'に変え、'Picture 4'という印を貼り付けるコードを作成しましたが、シートごとに印が重複してしまいます。
- 印を押すためには、印押しBook.xslのシート1に請求書の雛形と角印を用意し、マクロを実行する必要があります。これにより、請求書の全シートに角印を押すことができます。
- ベストアンサー
エクセルマクロ 全シートに図の挿入をしたい
初心者です。よろしくお願いします。 エクセル2007 bookはxsl(互換表示で開いています) 200シートくらいある請求書です。全シートの同じ場所に角印を押したいです。 自分で考えたコードは1シート目の名前を"FACE"に変え印("Picture 4")を貼りつけておきます。 これだとSheets("FACE")に2個目の印が押されてしまいます。 印押しBook.xslのシート1に請求書の雛形と印を用意しておいて マクロを動かすと請求書Book.xslの全シートに印が押されるものが作れますか? Sub 印押しマクロ2() Dim myTop As Single, myLeft As Single myTop = Sheets("FACE").Shapes("Picture 4").Top myLeft = Sheets("FACE").Shapes("Picture 4").Left Sheets("FACE").Shapes("Picture 4").Copy Dim Sht As Worksheet For Each Sht In Worksheets Sht.Select ActiveSheet.Paste ActiveSheet.Shapes("Picture 4").Top = myTop ActiveSheet.Shapes("Picture 4").Left = myLeft Next Sht End Sub
- 111mimi111
- お礼率33% (2/6)
- Excel(エクセル)
- 回答数2
- ありがとう数2
- みんなの回答 (2)
- 専門家の回答
質問者が選んだベストアンサー
各シートで「Picture 4」の有無を手がかりにします。 sub macro1() dim myTop as single, myLeft as single dim w as worksheet mytop = worksheets("FACE").shapes("Picture 4").top myleft = worksheets("FACE").shapes("Picture 4").left worksheets("FACE").shapes("Picture 4").copy on error goto errhandle for each w in worksheets w.shapes("Picture 4").top = mytop w.shapes("Picture 4").left = myleft next exit sub errhandle: ’Picture 4の無いシートにPicture 4を貼り付ける w.paste resume end sub コツが掴めたら,印画像を「Picture 4」よりもっと分かりやすい名前にしておくと良いかもしれませんね。
その他の回答 (1)
- real beatin(@realbeatin)
- ベストアンサー率82% (174/211)
こんにちは。 オブジェクトや条件分岐の扱い方を主題に 基本的な書き方でお応えします。 Sub ReW9134729() Dim myTop As Single, myLeft As Single With Sheets("FACE").Shapes("Picture 4") myTop = .Top myLeft = .Left .Copy End With Dim Sht As Worksheet For Each Sht In Worksheets With Sht If UCase(.Name) <> "FACE" Then .Paste With .Shapes(.Shapes.Count) .Top = myTop .Left = myLeft End With End If End With Next End Sub
お礼
If UCase(.Name) <> "FACE" Thenでなるほど!と思いました。 同じ結果を得るのに色々な方法があって奥が深いですね。 ありがとうございました。
関連するQ&A
- Excelの罫線に関するマクロ
Excelの罫線に関するマクロ 罫線を引き、それを赤くするマクロを作ったのですが、赤罫線の下にもうひとつ罫線が表示されてしまいます。どこを削除すればよいのでしょうか。 ご教示お願いいたします。 Sub 罫線() Dim T1 As Single, L1 As Single Dim T2 As Single, L2 As Single Dim myShp As Shape With Range("c15") T1 = .Top L1 = .Left End With With Range("d14") T2 = .Offset(1, 1).Top L2 = .Offset(1, 1).Left End With Set myShp = ActiveSheet.Shapes.AddLine(L1, T1, L2, T2) ActiveSheet.Shapes.AddLine(L1, T1, L2, T2).Select With Selection.ShapeRange.Line .Visible = msoTrue .Style = msoLineSolid .Weight = 5# .ForeColor.SchemeColor = 10 End With End Sub よろしくお願いします。
- ベストアンサー
- その他MS Office製品
- エクセルのマクロについて
エクセル2010を使用しています。 工程表を作成するため、以下のマクロを組もうと苦戦しています。 任意のセルを選択し、マクロを実行すると選択したセルに線を引き 線の上部にテキストボックスで文字を入力できるようにするマクロを 作成しようとしています。 また、テキストボックスは文字入力後、大きさの自動調整をかけようと しています。 線を引くところまでは、うまくいったのですがテキストボックスの挿入→入力待機 →入力後、大きさの自動調整(幅)までのマクロがよくわかりません。 可能であれば、任意の選択したセルの中央に配置をしたいです。 お知恵をお貸しください。よろしくお願いします。 koutei() Dim SentakuTop As Single Dim SentakuLeft As Single Dim SentakuWidth As Single Dim SentakuHeight As Single Dim SentakuAddress As String Dim X0, Y0, X1, Y1 As Variant SentakuAddress = Selection.Address(ColumnAbsolute:=False, RowAbsolute:=False) With ActiveSheet.Range(SentakuAddress) SentakuTop = .Top SentakuLeft = .Left SentakuWidth = .Width SentakuHeight = .Height End With X0 = SentakuLeft Y0 = SentakuTop + SentakuHeight / 2 X1 = SentakuLeft + SentakuWidth Y1 = Y0 With ActiveSheet.Shapes.AddLine(X0, Y0, X1, Y1).Line .ForeColor.RGB = RGB(0, 0, 0) .Weight = 1 .BeginArrowheadStyle = msoArrowheadOval .EndArrowheadStyle = msoArrowheadOval End With End Sub
- ベストアンサー
- オフィス系ソフト
- マクロ 戻るボタンを押したらシートの1枚目に戻る
各シートに「戻る」というボタンを作りましたが、 「ボタンを押したらシートの1枚目をアクティブにする」というマクロを付けたいです。 下記は、『「戻る」というマクロを2枚目のシート以降すべてに付ける』というマクロです。 このマクロの中に、各シートの「戻る」ボタンを押せば、シートの1枚目に戻るような 指示を入れたいです。 分かる方いましたら、お願いします。。。 ※下記のマクロは以前ご回答いただいたマクロを引用したものです。 /////////////////////////////////// Sub 戻るボタン設置() Dim Sht As Worksheet For Each Sht In Worksheets If Not Sht.Name = Worksheets(1).Name Then With Sht For i = 1 To 1 '幅140、高さ20のボタンを追加 .Buttons.Add(900 * i, 10, 140, 20).Text = "戻る" Next i End With End If Next Sht Sheets(1).Select End Sub
- ベストアンサー
- オフィス系ソフト
- ファイルを開き、シートをコピーするマクロについての質問です。
VBA初心者の者です。解決法が分からないのでよろしくお願いします。 以下のことがマクロを用いて行いたいと思ってます。 (1)まず、シート1からnまであるデータの入ったファイル【以下、ファイル1】を指定して開き、それを別のシート1からnまであるファイル【以下、ファイル2】を指定して開きます。 (2)ファイル1の各々のシートからファイル2のおのおののシートにデータをコピーしたいと思っています。ただし、コピーするのは、ファイル1のシート1からファイル2のシート1、ファイル1のシート2からファイル2のシート2に、・・・、ファイル1のシートnからファイル2のシートnまでループさせたいです。 一応、自分で以下のようにマクロを組んでみましたが、上手く動きません。どこが違うのかをご指摘いただきたいです。 よろしくお願いします。 Public sh As Integer Public sht_n As Integer Public Lst As Integer Sub Macro1() Dim file1 As String file1 = Application.GetOpenFilename(Title:="ファイルを選択して下さい") If file1 = "" Or file1 = "false" Then MsgBox "ファイルOPEN不可", vbCritical End Else Workbooks.Open Filename:=FN1 End If Dim file2 As String file2 = Application.GetOpenFilename(Title:="ファイルを選択して下さい") If file2 = "" Or file2 = "false" Then MsgBox "ファイルOPEN不可", vbCritical End Else Workbooks.Open Filename:=FN2 End If sht_n = ActiveWorkbook.Sheets.Count Lst = sht_n + 1 For sh = 1 To sht_n Call CpSh(sh) Next sh End Sub Sub CpSh(s) Dim st As String st = Sheets(s).Name Sheets(st).Select Workbook("FA1").Activate Sheets("st").Select Cells.Select Selection.Copy Workbook("FA2").Activate Sheets("st").Select Range("A1").Select ActiveSheet.Paste End Sub
- 締切済み
- オフィス系ソフト
- Excel VBA 図をクリップボード介さずコピー
Excelシートのアイコンの画像をクリップボードを使わずにコピーするVBAコードを教えてください。 (Windows10,Excel2016) 具体的には、 1) Sheet1を選択する。 2) 挿入タブのアイコンをクリックする。 3) しばらくするとアイコンの挿入のウインドウが表示される。 4) アクセシビリティに9つのアイコンが表示されているので 一番左のアイコンをクリックしてチェックマークを付けて 右下の挿入ボタンをクリックする 5) Sheet1に車椅子のアイコンが挿入される(左側の図参照)。 6) このアイコンを選択すると左上のボックスにグラフィックス 1と表示される。 VBAで、Sheet1のシートの車椅子のアイコンをコピーして、 Sheet2のシートの同じ位置に貼り付ける場合、 以下のようなコードでは、 四角形全体が塗りつぶされたアイコンになってしまいます(右側の図参照) 車椅子のアイコンにするにはどのように記述すればよいでしょうか。 ------------------------------------- Sub test() Dim myType As MsoAutoShapeType Dim myLeft As Integer Dim myTop As Integer Dim myWidth As Integer Dim myHeight As Integer Sheets("sheet1").Select Sheets("sheet1").Shapes("グラフィックス 1").Select myType = Selection.ShapeRange.AutoShapeType myLeft = Selection.ShapeRange.Left myTop = Selection.ShapeRange.top myWidth = Selection.ShapeRange.Width myHeight = Selection.ShapeRange.Height Sheets("sheet2").Select ActiveSheet.Shapes.AddShape(myType, myLeft, myTop, myWidth, myHeight).Select End Sub -------------------------------------
- 締切済み
- Excel(エクセル)
- EXCEL マクロの指定の仕方
マクロで線の色を指定したいのですが、上手くいかず困っています .ForeColor.RGB = Worksheets("sheet1").Range("F2").Interior.ColorIndex 赤色を指定したいのですがBにどういうコードを入れれば良いですか? FはVlookupで列Bより色を指定するようにしています。 マクロは始めたばかりで良く分からないので、他に必要な情報もわかりません 必要な情報なども併せて教えてください。 よろしくお願いします。 Dim rngStart As Range Dim rngEnd As Range Dim BX As Single, BY As Single, EX As Single, EY As Single Set rngStart = Worksheets("sheet2").Cells.Find(What:=Worksheets("sheet1").Range("D2"), LookIn:=xlValues, LookAt:=xlWhole) Set rngEnd = Worksheets("sheet2").Cells.Find(What:=Worksheets("sheet1").Range("E2"), LookIn:=xlValues, LookAt:=xlWhole) BX = rngStart.Left BY = rngStart.Top EX = rngEnd.Left + rngEnd.Width EY = rngEnd.Top With Worksheets("sheet2").Shapes.AddLine(BX, BY + 10, EX, EY + 10).line .ForeColor.RGB = Worksheets("sheet1").Range("F2").Interior.ColorIndex .Weight = 3 .EndArrowheadStyle = msoArrowheadTriangle End With
- ベストアンサー
- Excel(エクセル)
- 画像をマクロでエクセルシートに貼り付けるには
画像をマクロを使ってエクセルシートに貼り付けようとしています。 2つ質問があります。 下記のマクロをベースとして。 (1)画像の縦横比を固定のまま、貼り付けたい。LockPictureAspectRatio=msoTrueだろうと思うのですが、見つかりません。 LockPictureAspectRatioは、画像のバケツボタンの fill effect/picture/select picture/insert/ から来ています。 (2)位置をセルを選んで与えたい。つまり、Cell(10,10) --> pointへの変換方法を教えて下さい。 下のマクロでは、x=100,y=100と与えていますが、これを、セルを選ぶことで与えたいのです。 Sub myMacro() Dim myPicture As String Dim a As Object myPicture = "C:\Documents and Settings\nrjito\My Documents\My Pictures\test.jpg" Set a = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 100, 100, 300, 300) a.Fill.ForeColor.RGB = RGB(255, 255, 255) a.Fill.Transparency = 0 a.LockAspectRatio = msoTrue a.Fill.UserPicture myPicture End Sub よろしくお願い致します。
- ベストアンサー
- オフィス系ソフト
- excel2000マクロについて
下記の様なマクロを書いていますが、別のマクロの記述の仕方で短縮に書くことはできないでしょうか。 Sub 承認捺印() Sheets("実行").Select If Range("E13").Value = "申請者" Then Sheets("ログイン").Select If Range("F11").Value = "a8012661" Then Sheets("印章").Select ActiveSheet.Shapes("Picture 15").Copy Call 申請者捺印 End If If Range("F11").Value = "a6601456" Then Sheets("印章").Select ActiveSheet.Shapes("Picture 16").Copy Call 申請者捺印 End If If Range("F11").Value = "t9907028" Then Sheets("印章").Select ActiveSheet.Shapes("Picture 17").Copy Call 申請者捺印 End If If Range("F11").Value = "a7545410" Then Sheets("印章").Select ActiveSheet.Shapes("Picture 18").Copy Call 申請者捺印 End If If Range("F11").Value = "t9806047" Then Sheets("印章").Select ActiveSheet.Shapes("Picture 19").Copy Call 申請者捺印 End If If Range("F11").Value = "t0206030" Then Sheets("印章").Select ActiveSheet.Shapes("Picture 20").Copy Call 申請者捺印 End If end if end sub Sub 申請者捺印() Sheets("報告票").Select Range("m3").Select ActiveSheet.Paste Range("a1").Select End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルマクロの分割方法について
Sub リスト登録() ' ' Macro3 Macro ' マクロ記録日 : 2008/6/2 ' ActiveSheet.Unprotect Password:="1234" If Range("G33").Value > 5 Then Sheets("リスト").Select ActiveSheet.Shapes("AutoShape 44").Select Selection.Copy Sheets("シート").Select Range("A15").Select ActiveSheet.Paste End If Dim Btn As Integer Dim strMsg As String strMsg = "リストに登録しますか?" Btn = MsgBox(strMsg, vbYesNo + vbQuestion, "MsgBox") If Btn = vbNo Then Dim YU As Shape For Each YU In ActiveSheet.Shapes If YU.Type = msoAutoShape Then YU.Delete End If Next If Btn = vbYes Then End If ActiveSheet.Protect Password:="1234", DrawingObjects:=True, Contents:=True, Scenarios:=True Range("C11").Select End End If Dim newRange1 As Range, newRange2 As Range, newRange3 As Range Select Case Sheets("").Range("B3").Value Case 1 Set newRange1 = Sheets("リスト").Range("I6") Set newRange2 = Sheets("リスト").Range("AH6") Set newRange3 = Sheets("リスト").Range("AI6") 中略 Case 1000 Set newRange1 = Sheets("リスト").Range("I1005") Set newRange2 = Sheets("リスト").Range("AH1005") Set newRange3 = Sheets("リスト").Range("AI1005") ActiveWorkbook.Save Case Else End Select Application.ScreenUpdating = False Sheets("シート").Range("G8,G10,G12:G23,G25:G29,G31:G32").Copy newRange1.PasteSpecial Paste:=xlPasteValues, _ Operation:=xlNone, SkipBlanks:=False, Transpose:=True newRange1.UnMerge Sheets("シート").Range("D34").Copy newRange2.PasteSpecial Paste:=xlPasteValues, _ Operation:=xlNone, SkipBlanks:=False, Transpose:=False Sheets("シート").Range("I29").Copy newRange3.PasteSpecial Paste:=xlPasteValues, _ Operation:=xlNone, SkipBlanks:=False, Transpose:=False Sheets("シート").Select Range("C11").Select Range("D34,G8:G32,I29").Select Selection.ClearContents Range("C11").Select Dim SP As Shape For Each SP In ActiveSheet.Shapes If SP.Type = msoAutoShape Then SP.Delete Range("D34:K34").Select Application.CutCopyMode = False Selection.Merge Range("B3").Select End If Next ActiveSheet.Protect Password:="1234", DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub 上記のマクロを作成しましたが、64Kを超えてしまう為、分割したいのですが、どのように分割すればよいのか方法がわかりません、どなたかお分かりの方がいらっしゃいましたら宜しくお願いします。 マクロシート1~2~3といったつなぎの構文がわかりません宜しくお願い致します。
- ベストアンサー
- その他(プログラミング・開発)
- エクセル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
- 締切済み
- オフィス系ソフト
お礼
希望通りにの結果が得られました。ありがとうございました。 時間が無く、コードを読み解く事ができませんが >印画像を「Picture 4」よりもっと分かりやすい名前にしておく その通りですね。