- 締切済み
Excel2010のマクロ使用時の画像が見れません
codotjtpの回答
- codotjtp
- ベストアンサー率26% (40/149)
セキュリティ対策ソフトウェアが邪魔を致していませんでしょうか? 複数のPCでの検証は可能でしょうか? どういう方式で、其のファイルが配布されていますでしょうか?
関連するQ&A
- マクロ初心者です。画像一括挿入について
初めてマクロを使っております。 以下ネットで拾ってきましたコードなのですが、 行いたいのは (1)挿入するセルを選択(複数可) (2)画像を一括選択 (3)縦横比率を固定して挿入:横か縦の長さは自分で設定 ※今のコードですと(3)で比率の固定ができず、伸びた画像が挿入されてしまいます これを可能にするには、一体どこをどう変えたらよいのでしょうか。 慣れない画像編集に悪戦苦闘しております。 どなたかご教授いただけますと幸いです。 どうぞよろしくお願い致します。 Sub try() Dim a As Range Dim cc As Range Dim W As Single Dim H As Single Dim mx As Long Dim fi As Long Dim i As Long Dim pkfile On Error GoTo extLine With Application Set a = .InputBox("画像挿入するセル選択" & vbLf & _ "複数選択可", _ "複数画像の一括挿入(セル選択)", _ Selection.Address, _ Type:=8) pkfile = .GetOpenFilename("すべての図" & _ "(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _ "*.jpe;*.png;*.bmp;*.gif)," & _ "*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _ "*.jpe;*.png;*.bmp;*.gif", 2, _ "挿入する図の選択(複数選択可)", , True) If Not IsArray(pkfile) Then MsgBox "ファイルが指定されていません", , _ "複数画像の一括挿入" GoTo extLine End If W = .InputBox("ヨコ", Type:=1) H = .InputBox("タテ", Type:=1) .ScreenUpdating = False End With mx = UBound(pkfile) fi = 1 For Each cc In a If cc.Address = cc.MergeArea.Item(1).Address Then Call picIns(cc, pkfile(fi), W, H) fi = fi + 1 If fi > mx Then Set cc = Nothing Exit For End If End If Next For i = fi To mx Set a = a(a.Rows.Count, 1).Offset(1) Call picIns(a, pkfile(i), W, H) Next extLine: Set a = Nothing Application.ScreenUpdating = False With err() If .Number <> 0 Then MsgBox .Number & ":" & .Description End With End Sub Sub picIns(ByVal r As Range, _ ByVal s As String, _ ByVal W As Single, _ ByVal H As Single) With ActiveSheet.Pictures.Insert(s).ShapeRange If (W > 0) And (H > 0) Then .LockAspectRatio = msoFalse .Width = W .Height = H ElseIf W > 0 Then .Width = W ElseIf H > 0 Then .Height = H End If .Left = r.Left .Top = r.Top End With End Sub
- ベストアンサー
- Excel(エクセル)
- Excel マクロ 写真挿入
こんにちは Excel2003で使っていた写真を挿入するマクロで困っています。 2003では問題なく画像が挿入され配布先でも見れましたが、2010では写真の保存先(リンク)を貼ったことになり、自分のPCでは問題ないくても送付先で見ることが出来ません。 どこをどのように変更すれば宜しいでしょうか?よろしくお願い致します。 Sub 画像をまとめてサイズ指定挿入改() Dim a As Range Dim bb As Integer Dim cc As Range Dim W As Single Dim H As Single Dim mx As Long Dim fi As Long Dim i As Long Dim pkfile On Error GoTo extLine With Application bb = .InputBox("貼り付ける画像の枚数を入力してください。 ※最大10枚までです。", Type:=2) Select Case bb Case "1" Set a = Range("A1") Case "2" Set a = Range("A1,H1") Case "3" Set a = Range("A1,H1,a22") Case "4" Set a = Range("A1,H1,a22,h22") Case "5" Set a = Range("A1,H1,a22,H22,A43") Case "6" Set a = Range("A1,H1,a22,H22,A43,H43") Case "7" Set a = Range("A1,H1,a22,H22,A43,H43,A64") Case "8" Set a = Range("A1,H1,a22,H22,A43,H43,A64,H64") Case "9" Set a = Range("A1,H1,a22,H22,A43,H43,A64,H64,A85") Case "10" Set a = Range("A1,H1,a22,H22,A43,H43,A64,H64,A85,H85") Case Else MsgBox "枚数は1~10の数字で入力してください" GoTo extLine End Select pkfile = .GetOpenFilename("すべての図" & _ "(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _ "*.jpe;*.png;*.bmp;*.gif)," & _ "*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _ "*.jpe;*.png;*.bmp;*.gif", 2, _ "挿入する図の選択(複数選択可)", , True) If Not IsArray(pkfile) Then MsgBox "ファイルが指定されていません", , _ "複数画像の一括挿入" GoTo extLine End If W = 320 H = 240 .ScreenUpdating = False End With mx = UBound(pkfile) fi = 1 For Each cc In a If cc.Address = cc.MergeArea.Item(1).Address Then Call picIns(cc, pkfile(fi), W, H) fi = fi + 1 If fi > mx Then Set cc = Nothing Exit For End If End If Next For i = fi To mx Set a = a(a.Rows.Count, 1).Offset(1) Call picIns(a, pkfile(i), W, H) Next extLine: Set a = Nothing Application.ScreenUpdating = False With Err() If .Number <> 0 Then MsgBox .Number & ":" & .Description End With End Sub Sub picIns(ByVal r As Range, _ ByVal s As String, _ ByVal W As Single, _ ByVal H As Single) With ActiveSheet.Pictures.Insert(s).ShapeRange If (W > 0) And (H > 0) Then .LockAspectRatio = msoFalse .Width = W .Height = H ElseIf W > 0 Then .Width = W ElseIf H > 0 Then .Height = H End If .Left = r.Left .Top = r.Top End With End Sub Private Sub CommandButton1_Click() 画像をまとめてサイズ指定挿入改 End Sub
- ベストアンサー
- Excel(エクセル)
- 2つのものが一致時に転記するマクロ
いつもお世話になります。 ここのサイトで 2つのブックでIDが一致したら 横にある文字を転記するというマクロがあるのですが 同じIDが続いても転記先のエクセルに全て転記したいと質問させて頂き そのマクロを使わせて頂いたのですが IDと時間を一致したものを転記させなければいけなくなりました A列の時間とB列のIDを一致したときに 大元に転記させるのは、変数で2つの項目を設定して 確認させればいいのかと思っていましたが上手くいきません 更に、データ量が多いので マクロを動かすたびに応答なしになるので コードをfindから別なコードを変えたほうがよろしいのでしょうか? 下記にマクロのコードと構成と画像を記述させて頂きます お手数ですがご教授して頂けないでしょうか? 恐縮ですがよろしくお願いいたします。 Sub 転記改造() Dim w0 As Worksheet, w1 As Worksheet Dim h As Range, Target As Range Dim i As Range, Target1 As Range Dim FirstAddress As String Set w0 = Workbooks("IDデータ.xls").Worksheets(1) Set w1 = Workbooks("ID管理票.xls").Worksheets(1) For Each h In w0.Range("A2:A" & w0.Range("A65536").End(xlUp).Row) For Each i In w0.Range("B2:B" & w0.Range("A65536").End(xlUp).Row) If h.Offset(, 1).Value = "確認" Then Set Target = w1.Range("D11:D60000").Find(what:=h.Value, LookIn:=xlValues, lookat:=xlWhole) If Not Target Is Nothing Then FirstAddress = Target.Address Do If Target.Offset(, -1).Value = "" Then Target.Offset(, -1) = "確認" Exit Do Else Set Target = w1.Range("D11:D60000").FindNext(Target) End If Loop While FirstAddress <> Target.Address End If End If Next next End Sub
- ベストアンサー
- Excel(エクセル)
- 複数のエクセルシートをまとめるマクロ
下は複数のエクセルファイルを一つにするマクロですが、100万件を超えるためcsvで保存するようにするにはどこを変更したらよいでしょうか。 よろしくお願いします。 Sub Sample() Dim t As Single Dim strPath As String Dim strFileName As String Dim WB1 As Workbook Dim WS1 As Worksheet Dim WS2 As Worksheet Dim lngRowCount As Long 'A列に値が入っているデータ数 t = Timer 'まとめたいシート Set WS2 = ThisWorkbook.Worksheets(1) strPath = ThisWorkbook.Path strFileName = Dir(strPath & "\*.xls*") Do While strFileName <> "" If strFileName <> ThisWorkbook.Name Then Set WB1 = Workbooks.Open(strPath & "\" & strFileName) Set WS1 = WB1.Worksheets(1) With WS1.Range("A1") lngRowCount = .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row - .Row If lngRowCount >= 1 Then With .Resize(lngRowCount, 14).Offset(1) .Copy WS2.Range("A" & WS2.Rows.Count).End(xlUp).Offset(1) End With End If End With WB1.Close False End If strFileName = Dir Loop MsgBox "まとめ処理をしました。処理時間 " & Format((Timer - t) / 60 / 60 / 24, "h:mm:ss") End Sub
- ベストアンサー
- Excel(エクセル)
- マクロを実行すると画像がズレてしまいます
VBAで汎用のものを利用して以下のようなマクロを組んだのですが、画像を挿入すると少しずつずれていってしまいます。 原因が分かる人がいましたらご教授ください。 下のを見てもわかると思いますが、VBAについてはまったくの初心者です よろしくお願いします。 またよろしければ1枚目でA3を指定すると2枚目もA3に重ねて貼ってしまうミスも訂正してくれると助かります。 Private Sub CommandButton1_Click() Dim strFilter As String Dim Filenames As Variant Dim PIC As Picture ' 「ファイルを開く」ダイアログでファイル名を取得 strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png" Filenames = Application.GetOpenFilename( _ FileFilter:=strFilter, _ Title:="図の挿入(複数選択可)", _ MultiSelect:=True) If Not IsArray(Filenames) Then Exit Sub ' ファイル名をソート Call BubbleSort_Str(Filenames, True, vbTextCompare) ' 貼り付け開始セルを選択 Dim ActCell As Range Set ActCell = ActiveCell ' マクロ実行中の画面描写を停止 Application.ScreenUpdating = False ' 順番に画像を挿入 For i = LBound(Filenames) To UBound(Filenames) Set PIC = ActiveSheet.Pictures.Insert(Filenames(i)) '------------------------------------------------------------- ' 画像の各種プロパティ変更 '------------------------------------------------------------- With PIC .Top = ActiveCell.Top ' 位置:アクティブセルの上側に重ねる .Left = ActiveCell.Left ' 位置:アクティブセルの左側に重ねる .Placement = xlMove ' 移動するがサイズ変更しない .PrintObject = True ' 印刷する End With With PIC.ShapeRange .LockAspectRatio = msoTrue ' 縦横比維持 ' 画像の高さをアクティブセルにあわせる ' 結合セルの場合でも対応 .Height = 178.5 End With Static a Static p a = a + 1 b = (a - 1) / 4 c = (a - 2) / 4 d = (a - 3) / 4 e = a / 4 If b = Int(b) Then p = 58 * b + 3 ElseIf c = Int(c) Then p = 58 * c + 16 ElseIf d = Int(d) Then p = 58 * d + 29 ElseIf e = Int(e) Then p = 58 * (e - 1) + 42 End If ' 次の貼り付け先を選択(アクティブセルにする)[例:5個下のセル] Cells(p, 1).Select Set PIC = Nothing Next i End Sub
- ベストアンサー
- その他MS Office製品
- H列の画像の下に画像を挿入できるようにしたい
H列の画像の下に画像を挿入できるようにしたいです。 マクロを組んでみたのですが、A列に画像があった場合、 その下に画像が挿入されてしまいます。 H列のみで判断して挿入するにはどうすればよろしいでしょうか。 Sub 改修後写真添付() Dim FileName As Variant Dim I, F, endRow As Long Dim sheetName As String Dim shp As Shape sheetName = ActiveSheet.Name FileName = Application.GetOpenFilename(MultiSelect:=True) On Error GoTo err_shori If Range("H5") = "" Then I = 5 Range("H5").Value = "画像添付" Else For Each shp In ActiveSheet.Shapes endRow = Application.Max(endRow, shp.BottomRightCell.Row) Next I = 2 + endRow End If For F = 1 To UBound(FileName) With Sheets(sheetName).Pictures.Insert(FileName(F)) .Top = Range("H" & I).Top .Left = Range("H" & I).Left .Width = "170" .Height = "165" .Cut End With With Sheets(sheetName) .Range("H" & I).Select ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False End With I = I + 14 Next F MsgBox UBound(FileName) & "個の画像ファイルが挿入されました。" Exit Sub err_shori: MsgBox "キャンセルされました。" End Sub
- ベストアンサー
- Visual Basic
- 画像をエクセルに貼り付けるマクロ
画像をエクセルに貼り付けるマクロ 複数の画像をエクセルに貼り付ける機会が多く、下記のマクロを利用しています。これは他人が作ったものでその人が今はいないため修正の仕方がわかりません。 これだとヨコに2個の画像で縦方向に画像が貼り付けられます。これをヨコに3個の画像で 縦方向に画像を貼り付けるようにしたいのですが、方法がわかりません。 お詳しい方どうかよろしくお願いします。 <現在> 1 2 3 4 5 6 <やりたいこと> 1 2 3 4 5 6 7 8 9 Sub Insertpic() Dim strFilter As String Dim Filenames As Variant Dim pic As picture Dim sc As Range Dim i As Long Dim j As Long Dim k As Long '「ファイルを開く」ダイアログでファイル名を取得 strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png" Filenames = Application.GetOpenFilename( _ FileFilter:=strFilter, _ Title:="画像の挿入(複数画像が選択できます)", _ MultiSelect:=True) If Not IsArray(Filenames) Then Exit Sub ' 貼り付け開始セルを選択 'ActicveCellRange("C5").Select ' マクロ実行中の画面描写を停止 Application.ScreenUpdating = False ' 順番に画像を挿入 For i = LBound(Filenames) To UBound(Filenames) Set pic = ActiveSheet.Pictures.Insert(Filenames(i)) '画像の大きさ指定 With pic.ShapeRange .Height = 120# .Width = 175# .Rotation = 0# End With ' 次の貼り付け先を選択 Select Case i Mod 2 Case 1 '奇数回目 ActiveCell.Offset(, 4).Select Case 0 '偶数回目 ActiveCell.Offset(11, -4).Select End Select Set pic = Nothing Next i ' 終了 Application.ScreenUpdating = True MsgBox i - 1 & "枚の画像を挿入しました", vbInformation End Sub
- ベストアンサー
- オフィス系ソフト
- Excel2003のマクロで複数の罫線を引きたい
Excel2003のマクロで複数の罫線を引きたい 本日(3月2日)の午前中に罫線のVBAに関する質問をして解決したのですが、今度は複数のセルにわたる罫線を複数引きたいのですが、ご教示お願いいたします。 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 このコードで(14行目と15行目の間、C列からD列)に赤の太線が表示されるようになりました。 さらにこれに加えて一度で、この罫線プラスA列の10行目からC列の14行目に引く罫線を加えたいのですが 上記コードにどのように書きくわえれば良いのでしょうか。 たびたびですみませんが、ご教示よろしくお願いいたします。
- ベストアンサー
- その他MS Office製品
- 【エクセルマクロ】画像挿入について教えてください。
Excel2010で下記マクロを実行し、 画像挿入元のフォルダ名を変更・削除したり、メールに添付して送信したりすると「リンクされたイメージを表示できません。ファイルが移動または削除されたか、名前が変更された可能性があります。リンクに正しいファイル名と場所が指定されていることを確認してください。」 と表示されます。 Excel2010では、Shapes.Addメソッドを使用するとリンク解除ができるとのことで、 初心者ながら色々試してみたのですが、うまくいきません。 マクロ初心者のため、詳しく教えていただけると大変助かります。 Private Sub Del_Btn_Click() 指定セル範囲 = "C18:K500" With ActiveSheet Set セル範囲 = .Range(指定セル範囲) For Each 図形 In .Shapes If 図形.Type = msoPicture Then Set 共有セル範囲 _ = Intersect(Range(図形.TopLeftCell, 図形.BottomRightCell), セル範囲) If Not (共有セル範囲 Is Nothing) Then 図形.Delete End If End If Next End With End Sub Private Sub Ins_Btn_Click() Dim fName As Variant Dim i As Long Dim j As Integer Dim k As Integer Dim Pict As Picture Const z1 As Long = 246 'サイズ指定 Const z2 As Long = 184 'サイズ指定 Dim z3 As Long '上位置 z3 = 306 k = 1 fName = Application.GetOpenFilename("JPGファイル, *.jpg", MultiSelect:=True) If IsArray(fName) Then Application.ScreenUpdating = False '配列に格納されたファイル名をソート BubbleSort fName, True 'If UBound(fName) >= 19 Then ' j = 19 ' Else j = UBound(fName) 'End If For i = 1 To j Set Pict = ActiveSheet.Pictures.Insert(fName(i)) If i Mod 6 = 5 Then z3 = z3 + 18.5 - k k = k + 0.5 End If If i Mod 2 = 1 Then With Pict .Width = z1 '横型 .Height = z2 '縦型 .Top = z3 + 146.5 * (i - 1) '上位置 .Left = 83 '左位置 .Locked = False ico = ico + z1 + 10 '間隔指定 End With Else With Pict .Width = z1 '横型 .Height = z2 '縦型 .Top = z3 + 146.5 * (i - 2) '上位置 .Left = 350 '左位置 .Locked = False ico = ico + z1 + 10 '間隔指定 End With End If ActiveCell.Offset(2, 0).Activate Application.StatusBar = "処理中:" & i & "/" & UBound(fName) & "枚目" Next i End If With Application .StatusBar = False .ScreenUpdating = True End With Set Pict = Nothing If i > 0 Then MsgBox j & "枚の画像を挿入しました", vbInformation End If End Sub '値の入替え Public Sub Swap(ByRef Dat1 As Variant, ByRef Dat2 As Variant) Dim varBuf As Variant varBuf = Dat1 Dat1 = Dat2 Dat2 = varBuf End Sub '配列のバブルソート Public Sub BubbleSort(ByRef aryDat As Variant, _ Optional ByVal SortAsc As Boolean = True) Dim i As Long Dim j As Long For i = LBound(aryDat) To UBound(aryDat) - 1 For j = LBound(aryDat) To LBound(aryDat) + UBound(aryDat) - i - 1 If aryDat(IIf(SortAsc, j, j + 1)) > aryDat(IIf(SortAsc, j + 1, j)) Then Call Swap(aryDat(j), aryDat(j + 1)) End If Next j Next i End Sub どうぞよろしくお願いいたします。
- 締切済み
- Excel(エクセル)
- エクセルのマクロについて
エクセル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
- ベストアンサー
- オフィス系ソフト
補足
セキュリティ系を切ったりしてもダメでした。 複数のPCでも検証しています。 >どういう方式で、其のファイルが配布されていますでしょうか? これに関しましては自分のPCにある画像をexcelで作成し、会社のサーバーに挙げています。 そこでは見れないようです。 また、メールで他のPCに送っても見れていません。