エクセルマクロで画像がずれる問題について -エクセルでマクロを使って画像を-

excel　マクロ　画像貼り付け位置入力　

このマクロを使って別々のシートにセル位置A１から縦に画像を挿入したいのですが　' 貼り付け開始セルを選択　　　　←マクロのプログラム部分　　Range("A1").Select のA１の部分をこのマクロを起動させたら excel画面内に四角　[　　　　] のボックスなどで表示させ　例　貼り付け指定位置を入力せよ　　　A＝[　　　] などと表示させそれに例えば　　　A＝[　５　] [　A5　]と入力すればマクロのプログラムも書き換えられるようにしたいのですお願いいたします Sub 複数の画像を挿入() 　　　　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) 　　　　　　' 貼り付け開始セルを選択　　Range("A1").Select 　　　　　　' マクロ実行中の画面描写を停止　　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 = ActiveCell.MergeArea.Height 　　　　End With 　　　　' 次の貼り付け先を選択（アクティブセルにする）[例：5個下のセル] 　　　　ActiveCell.Offset(5).Select 　　　　　　　　Set PIC = Nothing 　　Next i 　　　　' 終了　　Application.ScreenUpdating = True 　　MsgBox i－1 & "枚の画像を挿入しました", vbInformation End Sub

画像をエクセルに貼り付けるマクロ

画像をエクセルに貼り付けるマクロ複数の画像をエクセルに貼り付ける機会が多く、下記のマクロを利用しています。これは他人が作ったものでその人が今はいないため修正の仕方がわかりません。これだとヨコに2個の画像で縦方向に画像が貼り付けられます。これをヨコに3個の画像で縦方向に画像を貼り付けるようにしたいのですが、方法がわかりません。お詳しい方どうかよろしくお願いします。＜現在＞１　　２３　　４５　　６＜やりたいこと＞１　　２　　３４　　５　　６７　　８　　９ 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

エクセル　工事写真　回転して挿入

エクセルで工事写真台帳を作っています。いろいろ検索して指定したセル内に画像を挿入できるようになりましたが、左へ90度回転させて挿入したいのです。よろしくお願いします。 Sub 複数の画像を挿入() 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) ' 貼り付け開始セルを選択 'ActicveCellRange("C5").Select ' マクロ実行中の画面描写を停止 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 = ActiveCell.MergeArea.Height End With ' 次の貼り付け先を選択（アクティブセルにする） Select Case i Mod 2 Case 1 '奇数回目 ActiveCell.Offset(, 2).Select Case 0 '偶数回目 ActiveCell.Offset(5, -2).Select End Select Set PIC = Nothing Next i ' 終了 Application.ScreenUpdating = True MsgBox i - 1 & "枚の画像を挿入しました", vbInformation End Sub

マクロを実行すると画像がズレてしまいます

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

エクセルで写真挿入　マクロ

質問させて下さい。エクセルで工事写真アルバムを作成したく、下記資料を参考にさせていただいたのですが・・・画像の挿入順番を変更するには、どうしたら良いのでしょうか？ ※ActiveCell.Offset(5).Selectの部分を【順番】になるように【順番】・・・画像１を任意セルに指定し複数の画像を右→下→右→下　　　　　　（右には2セル移動　下には5セル移動）　　A　　　B　　　C　　　D　　　E　　　F 1　　　　画像1　　　　　画像2 2 3 4　　　　画像3　　　　　画像4 5 6 7　　　　画像5　　　　　画像6 ・・・　　　　・・・　　　　　　　・・・・　 100 【資料】 Sub 複数の画像を挿入() 　　　　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) 　　　　　　' 貼り付け開始セルを選択　　’ActicveCellRange("C5").Select 　　　　　　' マクロ実行中の画面描写を停止　　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 = ActiveCell.MergeArea.Height 　　　　End With 　　　　' 次の貼り付け先を選択（アクティブセルにする）[例：5個下のセル] 　　　　ActiveCell.Offset(5).Select 　　　　　　　　Set PIC = Nothing 　　Next i 　　　　' 終了　　Application.ScreenUpdating = True 　　MsgBox i-1 & "枚の画像を挿入しました", vbInformation End Sub ' バブルソート（文字列） Private Sub BubbleSort_Str( _ 　　ByRef Source As Variant, _ 　　Optional ByVal SortAsc As Boolean = True, _ 　　Optional ByVal Compare As VbCompareMethod = vbTextCompare) 　　　　If Not IsArray(Source) Then Exit Sub 　　　　Dim i As Long, j As Long 　　Dim vntTmp As Variant 　　For i = LBound(Source) To UBound(Source) - 1 　　　　For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1 　　　　　　If StrComp(Source(IIf(SortAsc, j, j + 1)), _ 　　　　　　　　　　　 Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then 　　　　　　　　vntTmp = Source(j) 　　　　　　　　Source(j) = Source(j + 1) 　　　　　　　　Source(j + 1) = vntTmp 　　　　　　End If 　　　　Next j 　　Next i End Sub

エクセルで写真挿入　マクロ

質問させて下さい。エクセルで会社で写真台帳を作成しています。このマクロは以前、会社にいた人が作ったらしいのですが、その後退職してしまい、だれもマクロの内容が分からず困っています。よろしくお願いします。【資料】を添しましたので、どの場所をどのように変更すればよいのか、教えて下さい。【順番】・・・縦3枚横2枚のA3の写真台紙で下記の順番になるように画像を貼付たい　　A　　　B　　　C　　　D　　　E　　　F　　　G　　　H 1　　　　画像1　　　コメント欄　　　コント欄　　　　画像4 2 3 4　　　　画像2　　　コメント欄　　　コメント欄　　　　画像5 5 6 7　　　　画像3　　　コメント欄　　　コメント欄　　　　画像6 8 9 10　　　画像7　　　コメント欄　　　コメント欄　　　　画像9 ・・・　　　　　・・・　　　　　　・・・　　　　　・・・　　　　　　・・・・　 100 【資料】 Sub 画像挿入() 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) ' 貼り付け開始セルを選択 ' マクロ実行中の画面描写を停止 Application.ScreenUpdating = False ' 順番に画像を挿入 j = -1 For i = LBound(Filenames) To UBound(Filenames) Set Pic = ActiveSheet.Pictures.Insert(Filenames(i)) j = j + 1 '------------------------------------------------------------- ' 画像の各種プロパティ変更 '------------------------------------------------------------- With Pic .Top = ActiveCell.Top ' 位置：アクティブセルの上側に重ねる .Left = ActiveCell.Left ' 位置：アクティブセルの左側に重ねる .Placement = xlMove ' 移動するがサイズ変更しない .PrintObject = True ' 印刷する End With With Pic.ShapeRange .LockAspectRatio = msoFalse ' 縦横比維持 ' 画像の幅をアクティブセルにあわせる ' 結合セルの場合でも対応 .Height = ActiveCell.MergeArea.Height 'Height：高さに合わせる場合 .Width = ActiveCell.MergeArea.Width 'Width：幅に合わせる場合 End With ' 次の貼り付け先を選択（アクティブセルにする）[例：5個下のセル] If j Mod 2 = 0 Then ActiveCell.Offset(15, 0).Select Else ActiveCell.Offset(0, 13).Select End If Set Pic = Nothing Next i ' 終了 Application.ScreenUpdating = True MsgBox i - 1 & "枚の画像を挿入しました", vbInformation End Sub バブルソート（文字列） Private Sub BubbleSort_Str( _ ByRef Source As Variant, _ Optional ByVal SortAsc As Boolean = True, _ Optional ByVal Compare As VbCompareMethod = vbTextCompare) If Not IsArray(Source) Then Exit Sub Dim i As Long, j As Long Dim vntTmp As Variant For i = LBound(Source) To UBound(Source) - 1 For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1 If StrComp(Source(IIf(SortAsc, j, j + 1)), _ Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then vntTmp = Source(j) Source(j) = Source(j + 1) Source(j + 1) = vntTmp End If Next j Next i End Sub

マクロで写真貼付＿順番

マクロ初心者です。ネットでいろいろ調べて、写真をＡ3に6枚ずつ貼付できる下記のようなマクロを作りました。ですが順序がうまくできません。写真は1から順番に番号をつけてあって、番号順に並べたいのですが、マクロを実行すると文字として読み取るみたいで、 1、10、11、・・・・・・19、2、20、21・・・・となります。どなたかわかる方、お教え願います。初心者なのでコードを書いていただけると助かります。 Sub 画像挿入() 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) ' 貼り付け開始セルを選択 range("b4").Select ' マクロ実行中の画面描写を停止 Application.ScreenUpdating = False ' 順番に画像を挿入 j = -1 For i = LBound(Filenames) To UBound(Filenames) Set Pic = ActiveSheet.Pictures.Insert(Filenames(i)) j = j + 1 '------------------------------------------------------------- ' 画像の各種プロパティ変更 '------------------------------------------------------------- With Pic .Top = ActiveCell.Top ' 位置：アクティブセルの上側に重ねる .Left = ActiveCell.Left ' 位置：アクティブセルの左側に重ねる .Placement = xlMove ' 移動するがサイズ変更しない .PrintObject = True ' 印刷する End With With Pic.ShapeRange .LockAspectRatio = msoTrue ' 縦横比維持 ' 画像の幅をアクティブセルにあわせる ' 結合セルの場合でも対応 .Height = ActiveCell.MergeArea.Height End With ' 次の貼り付け先を選択（アクティブセルにする）[例：5個下のセル] ActiveCell.Offset(5).Select If i Mod 6 = 3 Then ActiveCell.Offset(-120, 17).Select ElseIf i Mod 6 = 0 Then ActiveCell.Offset(0, -17).Select End If Set Pic = Nothing Next i ' 終了 Application.ScreenUpdating = True MsgBox i - 1 & "枚の画像を挿入しました", vbInformation End Sub ' バブルソート（文字列） Private Sub BubbleSort_Str( _ ByRef Source As Variant, _ Optional ByVal SortAsc As Boolean = True, _ Optional ByVal Compare As VbCompareMethod = vbTextCompare) If Not IsArray(Source) Then Exit Sub Dim i As Long, j As Long Dim vntTmp As Variant For i = LBound(Source) To UBound(Source) - 1 For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1 If StrComp(Source(IIf(SortAsc, j, j + 1)), _ Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then vntTmp = Source(j) Source(j) = Source(j + 1) Source(j + 1) = vntTmp End If Next j Next i End Sub

AddPictureで複数の画像を挿入したい

エクセル2010で下のようなコードでPictures.InsertとFor文を使用して複数の画像を読み込んでます。ところが、Pictures.Insertを2010で使用すると画像がリンク貼付されてしまうため、エクセル2003で画像を見ることができません。そこで、AddPictureを使用しなければならないということは理解したのですが、ネット上のサンプルコードは１つのファイルを読み込む場合のものばかりで、今まで通りに複数の画像を読み込むためのコードがなかなかみつかりません。しかしながら、会社にはVBAを操作できる人がおらず、ネットと本で独学していますが、どうしても、どこにFor文を入れたらよいのかわかりません。厚かましいのは承知ですが、下に現在使用しているコードをコピペしましたので、どこを直せばよいのか教えていただけますでしょうか・・・。自分でやりきれる力があればよいのですが、会社にマクロを使える人がおらず、ネットと本を見ながらやっているのですが、これ以上自分で悩んでいる時間の余裕がありません。なんとかお助けいただけますでしょうか。よろしくお願いいたします。 -- Sub 画像挿入() Dim strFilter As String Dim Filenames As Variant Dim Pic As Picture ActiveSheet.Range("K8").Select 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) 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 = ActiveCell.MergeArea.Height End With ActiveCell.Offset(0, 7).Select Set Pic = Nothing Next i Application.ScreenUpdating = True End Sub

「複数の画像を挿入」の部分修正

過去ログから、失礼致します。下記、コードを修正したいのですがどこを修正すればよいか分からないのでご教示願います。１、ファイル名表示を、アドレス部分（C:\～）と拡張子部分を除いての表記にしたい。２、縦４×横２の台帳なので横２列に対応するものに変更したい。　　（縦４×横１であれば対応セルを変更すればよいのですが２列だとどうすればよいのか）３、挿入したら範囲内で中央配置にしたい　　（挿入後手修正しようとしても中央配置が選択できない） --------------------------------------------- Sub 複数の画像を挿入() 　　　　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) 　　　　　　' 貼り付け開始セルを選択　　Range("C5").Select 　　　　　　' マクロ実行中の画面描写を停止　　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 = ActiveCell.MergeArea.Height 　　　　End With 　　　　' 次の貼り付け先を選択（アクティブセルにする）[例：5個下のセル] 　　　　ActiveCell.Offset(5).Select 　　　　　　　　Set PIC = Nothing 　　Next i 　　　　' 終了　　Application.ScreenUpdating = True 　　MsgBox i & "枚の画像を挿入しました", vbInformation End Sub ' バブルソート（文字列） Private Sub BubbleSort_Str( _ 　　ByRef Source As Variant, _ 　　Optional ByVal SortAsc As Boolean = True, _ 　　Optional ByVal Compare As VbCompareMethod = vbTextCompare) 　　　　If Not IsArray(Source) Then Exit Sub 　　　　Dim i As Long, j As Long 　　Dim vntTmp As Variant 　　For i = LBound(Source) To UBound(Source) - 1 　　　　For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1 　　　　　　If StrComp(Source(IIf(SortAsc, j, j + 1)), _ 　　　　　　　　　　　 Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then 　　　　　　　　vntTmp = Source(j) 　　　　　　　　Source(j) = Source(j + 1) 　　　　　　　　Source(j + 1) = vntTmp 　　　　　　End If 　　　　Next j 　　Next i End Sub -----------------------------------------

写真貼り付けを3列で折り返したい

こんにちは。会社で写真台帳を作成しています。以下のVBAだと横2列の写真台帳になりますが、これを横3列の写真台帳にしたいと思っていますが、どのようにすればよいのでしょうか？このマクロは以前、会社にいた人が作ったらしいのですが、その後退職してしまい、だれもマクロの内容が分からず困っています。よろしくお願いします。 Sub 写真台帳() 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) ' 貼り付け開始セルを選択 Range("A5").Select ' マクロ実行中の画面描写を停止 Application.ScreenUpdating = False ' 順番に画像を挿入 j = -1 For i = LBound(Filenames) To UBound(Filenames) j = j + 1 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 ' 縦横比維持 ' 画像の幅をアクティブセルにあわせる ' 結合セルの場合でも対応 .Width = ActiveCell.MergeArea.Width 'Height：高さに合わせる場合 End With ' 次の貼り付け先を選択（アクティブセルにする）[例：5個下のセル] If j Mod 2 = 0 Then ActiveCell.Offset(0, 1).Select Else ActiveCell.Offset(4, -1).Select End If Set PIC = Nothing Next i ' 終了 Application.ScreenUpdating = True MsgBox i - 1 & "枚の画像を挿入しました", vbInformation End Sub ' バブルソート（文字列） Private Sub BubbleSort_Str( _ ByRef Source As Variant, _ Optional ByVal SortAsc As Boolean = True, _ Optional ByVal Compare As VbCompareMethod = vbTextCompare) If Not IsArray(Source) Then Exit Sub Dim i As Long, j As Long Dim vntTmp As Variant For i = LBound(Source) To UBound(Source) - 1 For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1 If StrComp(Source(IIf(SortAsc, j, j + 1)), _ Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then vntTmp = Source(j) Source(j) = Source(j + 1) Source(j + 1) = vntTmp End If Next j Next i End Sub

エクセルマクロ画像についての質問です。

エクセルマクロについての質問です。下記のコードでセルに画像を合わせて貼り付け、表を作成しています。が、このコードだと画像の保存先を移動させると画像が表示されなくなり、分類でフィルターをかけるとバラバラの違う画像が表示されてしまったりして困っています・・・。どなたか良いご意見を頂ければと思い、投稿しました。よろしくお願いします！ Sub PictFit() Dim PicFile As String Dim Pic As Picture PicFile = Application.GetOpenFilename() '画像のパスを取得 If PicFile = "False" Then Exit Sub Set Pic = ActiveSheet.Pictures.Insert(PicFile) '画像を貼り付ける With Pic .Height = ActiveCell.MergeArea.Height '画像の高さ .Top = ActiveCell.Top '画像の上位置を変更 .Left = ActiveCell.Left + (ActiveCell.MergeArea.Width - .Width) / 2 '画像の横位置を変更(セル幅中央に画像中央) End With End Sub

Excelマクロのオフセットについて

マクロのセルのオフセットについて質問です。複数の画像（仮に7枚）を一度に張り付ける際に If ActiveCell.Column = 1 Then ActiveCell.Offset(, 8).Select Else ActiveCell.Offset(4, -8).Select End If このようなマクロ組むと 1　2 3　4 5　6 7 という感じになります。列は8列空いて、行は4行空くことになると思うのですがこれを 1　2　3 4　5　6 7 としたい場合はどのようなマクロの書き方をすればよいのでしょうか？ご指導の程宜しくお願いします。マクロを張り付けておきます。 Declare Function SetCurrentDirectory Lib "kernel32" Alias _ "SetCurrentDirectoryA" (ByVal CurrentDir As String) As Long Sub 画像一括貼り付け() Dim Fname As Variant, fe As Variant Dim Fn As Variant, Pic As Shape Dim pno As Long Dim myFileName As String Range("A8").Select SetCurrentDirectory "P:\投レ＋相模原\F-POT KBB42365\外観確認" Fname = Application.GetOpenFilename _ ("jpg,*.jpg,jpeg,*.jpeg,bmp,*.bmp,gif,*.gif,png,*.png", 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:=360, Height:=270) With Pic .ScaleWidth 1, msoTrue .ScaleHeight 1, msoTrue .Top = ActiveCell.Top ' 位置：アクティブセルの上側に重ねる .Left = ActiveCell.Left ' 位置：アクティブセルの左側に重ねる .Placement = xlMove ' 移動するがサイズ変更しない End With If ActiveCell.Column = 1 Then ActiveCell.Offset(, 8).Select Else ActiveCell.Offset(4, -8).Select End If Set Pic = Nothing pno = pno + 1 Next Application.ScreenUpdating = True Range("A1").Select MsgBox pno & "枚の画像を挿入しました", vbInformation End Sub

Excelの画像一括挿入マクロを改良したい

以下の質問の回答者さんの頂戴し少し改変して、マクロでExcelの画像を一括挿入しています。 https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q12139845762 貼り付けるセルが一列に並び画像を連続して下に貼り付けるだけであればこちらのマクロで大丈夫なのですが、貼り付けるセルが2列3行になり、 1番目の写真　　2番目の写真 3番目の写真　　4番目の写真 5番目の写真　　6番目の写真という風に貼り付けたいときにどうしたらよいのかがわかりません。 ActiveCell.Offset(21).Select の所で、セルの行が21下がって貼り付けられるということはわかるのですが… 使っているExcelファイルはいわゆるセルが方眼紙のようになっており、15行19列のセルを結合してそこに写真を貼り付けています。 1番目の写真を貼り付けた後に2列移動して貼り付けたいです。ご教授いただければ幸いです。使用しているマクロ↓ Sub ShpAdTest() Dim FNames As Variant, myShp As Shape Dim Fn As String, i As Long FNames = Application.GetOpenFilename( _ filefilter:="Image(*.jpg;*.gif;*.bmp;*.png),*.jpg;*.gif;*.bmp;*.png", _ Title:="図の挿入(複数選択可）", _ MultiSelect:=True) If Not IsArray(FNames) Then Exit Sub Call BubbleSort_Str(FNames, True, vbTextCompare) Application.ScreenUpdating = False For i = LBound(FNames) To UBound(FNames) PasteShp (FNames(i)) With ActiveSheet.Shapes(ActiveSheet.Shapes.Count) .LockAspectRatio = msoTrue .Placement = xlMove .DrawingObject.PrintObject = True .Height = ActiveCell.MergeArea.Height If .Width > ActiveCell.MergeArea.Width Then .Width = ActiveCell.MergeArea.Width End If .Top = ActiveCell.MergeArea.Top + (ActiveCell.MergeArea.Height - .Height) / 2 .Left = ActiveCell.MergeArea.Left + (ActiveCell.MergeArea.Width - .Width) / 2 End With ActiveCell.Offset(21).Select Next Call ShpCutPaste Application.ScreenUpdating = True End Sub Sub PasteShp(fname As Variant) Dim Shp As Shape Set Shp = ActiveSheet.Shapes.AddPicture( _ filename:=fname, _ linktofile:=False, savewithdocument:=True, _ Left:=Selection.Left, Top:=Selection.Top, _ Width:=0, Height:=0) Shp.ScaleHeight 1!, msoTrue Shp.ScaleWidth 1!, msoTrue Set Shp = Nothing End Sub Private Sub BubbleSort_Str( _ ByRef Source As Variant, _ Optional ByVal SortAsc As Boolean = True, _ Optional ByVal Compare As VbCompareMethod = vbTextCompare) If Not IsArray(Source) Then Exit Sub Dim i As Long, j As Long Dim vntTmp As Variant For i = LBound(Source) To UBound(Source) - 1 For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1 If StrComp(Source(IIf(SortAsc, j, j + 1)), _ Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then vntTmp = Source(j) Source(j) = Source(j + 1) Source(j + 1) = vntTmp End If Next j Next i End Sub ' ↓ 画像のリンク解除と画像ファイルサイズの低減 Private Sub ShpCutPaste() Dim Shp As Shape, Nm As String Dim x As Double, y As Double Application.ScreenUpdating = False For Each Shp In ActiveSheet.Shapes With Shp x = .Left y = .Top Nm = .Name .Cut End With ActiveSheet.PasteSpecial Format:="図 (JPEG)", _ Link:=False, DisplayAsIcon:=False With Selection .Left = x .Top = y .Name = Nm End With Application.CutCopyMode = False Next Application.ScreenUpdating = 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 のセルに貼り付けという具合にしたいです。よろしくお願いします。

【エクセルマクロ】画像挿入について教えてください。

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 どうぞよろしくお願いいたします。

エクセルのマクロで

お世話になります下記のマクロで実行した所１００まで書式設定で保護、ロックしたいのですが b3：l3はロックするものの４行目以降はロックしませんどうしたらいいでしょうかもう１つ、このシートはいつもｃ３からはじめたいのですが If ActiveCell.Value >= "" Then の部分はどうしたらいいでしょうかよろしくおねがいいたします初心者でバカな質問ですみません Sub マクロ１() Dim i As Integer For i = 1 To 100 If ActiveCell.Value >= "" Then Range("B3:l3").Select Selection.Locked = True Selection.FormulaHidden = False End If ActiveCell.Offset(1, 0).Select Next End Sub

エクセルVBA

アクティブ「セル」のある「行」をコピーし、そのアクティブセルの下へ挿入するマクロに、複数「セル」を選択している場合は、複数行を挿入するように追記するには、どうしたらいいでしょうか？ Sub Macro1() Rows(1).Copy ActiveCell.EntireRow.Insert Shift:=xlDown Application.CutCopyMode = False ActiveCell.EntireRow.Hidden = False End Sub よろしくお願いします。m(_ _)m

セルを選択するマクロ(エクセル)

Sub test() x = ActiveCell.Row y = ActiveCell.End(xlToLeft).Column z = ActiveCell.End(xlToRight).Column Range(Cells(x, y), Cells(x, z)).Select End Sub アクティブセルが含まれている行のみで、データが入力されている連続したセルを選択状態にするマクロとして、上記を考えました。上記を違った形でもっと簡潔に表すことは可能でしょうか？

エクセルVBAでの画像ファイル名取得他

VBAについての質問です。 http://hp.vector.co.jp/authors/VA033788/kowaza.html#0158 上記をベースに、なんとかVBAを下記のように書き換えました。 Sub LoadPictures3() Dim Fnames As Variant Dim Fn As Variant Dim i As Integer Dim Pic As Picture Dim R As Range Dim R2 As Range Dim Pc As Integer Fnames = Application.GetOpenFilename("図(*.jpg;*.gif),*.jpg;*.gif", MultiSelect:=True) If TypeName(Fnames) = "Boolean" Then Exit Sub Application.ScreenUpdating = False '一枚目の貼付け位置 Set R = Range("B5") Set R2 = R.Offset(35) Pc = 0 For i = 1 To UBound(Fnames) Set Pic = ActiveSheet.Pictures.Insert(Fnames(i)) Select Case (i - 1) Mod 4 + 1 Case 1 Pc = Pc + 1 If Pc >= 2 Then ActiveSheet.HPageBreaks.Add R2 End If With R Pic.Left = .Left Pic.Top = .Top Pic.Width = 300 Pic.Height = 225 End With Case 2 With R.Offset(0, 6) '一枚目に対する二枚目の相対位置 Pic.Left = .Left Pic.Top = .Top Pic.Width = 300 Pic.Height = 225 End With Case 3 With R.Offset(18, 0) Pic.Left = .Left Pic.Top = .Top Pic.Width = 300 Pic.Height = 225 End With Case 4 With R.Offset(18, 6) Pic.Left = .Left Pic.Top = .Top Pic.Width = 300 Pic.Height = 225 End With '次ページの相対位置 Set R = R.Offset(39) End Select Next Application.ScreenUpdating = True End Sub ここで、画像の上の位置（B5のセル位置の画像の場合、B4）に元々の画像ファイル名を取得し、表記させたいのですが調べた所、multiselect:=Trueで複数ファイルを選択するときに画像名が図1、図2に変わっているようで、どうしていいかわかりません。後、画像を300×225の「変倍」画像にしたいのですがどのようにすれば可能でしょうか？全くVBAの知識がなく、上のURLを参考に、単語を調べつつ書き換えている状態で、変数やらなんやらの指定・書き方等わかりません。どなたかご教授願います。

行方向の同じ値のセルを結合するマクロ

ネットで色々調べながら、A列方向の同じ値のセルを結合させるマクロを作ってみたのですが、もっと簡単にできるようでしたら教えていただきたいです。どうぞよろしくお願いいたします。 Sub セル結合() Dim r As Integer '行数 Dim i As Integer 'カウンタ r = Sheets(1).Range("a1").CurrentRegion.Rows.Count - 1 Application.DisplayAlerts = False For i = 1 To r Cells(i, 1).Activate '項目の一つ下のセルをアクティブに If ActiveCell.Value = ActiveCell.Offset(1).Value Then Range(ActiveCell, ActiveCell.Offset(1)).Merge End If Next Application.DisplayAlerts = True End Sub

エクセルマクロで画像がずれる問題について

エクセル　マクロで困っています。画像がずれます。

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

お礼 2009/05/14 11:48

関連するQ&A

excel　マクロ　画像貼り付け位置入力

画像をエクセルに貼り付けるマクロ

エクセル　工事写真　回転して挿入

マクロを実行すると画像がズレてしまいます

エクセルで写真挿入　マクロ

エクセルで写真挿入　マクロ

マクロで写真貼付＿順番

AddPictureで複数の画像を挿入したい

「複数の画像を挿入」の部分修正

写真貼り付けを3列で折り返したい

エクセルマクロ画像についての質問です。

Excelマクロのオフセットについて

Excelの画像一括挿入マクロを改良したい

VBAで特定の文字が含まれている画像ファイル

【エクセルマクロ】画像挿入について教えてください。

エクセルのマクロで

エクセルVBA

セルを選択するマクロ(エクセル)

エクセルVBAでの画像ファイル名取得他

行方向の同じ値のセルを結合するマクロ

注目のQ&A

カテゴリ
一覧

専門家に質問してみよう
専門家登録

あなたにピッタリな商品が見つかる！ OKWAVE セレクト

エクセルマクロで画像がずれる問題について

エクセル マクロで困っています。画像がずれます。

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

お礼 2009/05/14 11:48

関連するQ&A

excel マクロ 画像貼り付け位置入力

画像をエクセルに貼り付けるマクロ

エクセル 工事写真 回転して挿入

マクロを実行すると画像がズレてしまいます

エクセルで写真挿入 マクロ

エクセルで写真挿入 マクロ

マクロで写真貼付＿順番

AddPictureで複数の画像を挿入したい

「複数の画像を挿入」の部分修正

写真貼り付けを3列で折り返したい

エクセル マクロ 画像についての質問です。

Excelマクロのオフセットについて

Excelの画像一括挿入マクロを改良したい

VBAで特定の文字が含まれている画像ファイル

【エクセルマクロ】画像挿入について教えてください。

エクセルのマクロで

エクセルVBA

セルを選択するマクロ(エクセル)

エクセルVBAでの画像ファイル名取得他

行方向の同じ値のセルを結合するマクロ

注目のQ&A

カテゴリ 一覧

専門家に質問してみよう 専門家登録

あなたにピッタリな商品が見つかる！ OKWAVE セレクト

エクセル　マクロで困っています。画像がずれます。

excel　マクロ　画像貼り付け位置入力　

エクセル　工事写真　回転して挿入

エクセルで写真挿入　マクロ

エクセルで写真挿入　マクロ

エクセルマクロ画像についての質問です。

カテゴリ
一覧

専門家に質問してみよう
専門家登録