- ベストアンサー
マクロで写真貼付_順番
OKwebbの回答
- OKwebb
- ベストアンサー率44% (92/208)
#1 の回答でいいと思います。 もし数値で比較するとなるとこんな感じ。 注意:数値以外のファイルが選択された時のエラー処理等はふくまれてません。 ' バブルソート Private Sub BubbleSort(ByRef Source As Variant) If Not IsArray(Source) Then Exit Sub Dim FSO Set FSO = CreateObject("Scripting.FileSystemObject") Dim i As Long, j As Long Dim j2 As Long, jj2 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 j2 = Val(FSO.GetBaseName(Source(j))) jj2 = Val(FSO.GetBaseName(Source(j + 1))) If j2 > jj2 Then vntTmp = Source(j) Source(j) = Source(j + 1) Source(j + 1) = vntTmp End If Next j Next i Set FSO = Nothing End Sub
関連するQ&A
- エクセルで写真挿入 マクロ
質問させて下さい。 エクセルで工事写真アルバムを作成したく、下記資料を参考にさせていただいたのですが・・・画像の挿入順番を変更するには、どうしたら良いのでしょうか? ※ActiveCell.Offset(5).Selectの部分を【順番】になるように 【順番】・・・画像1を任意セルに指定し複数の画像を右→下→右→下 (右には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列で折り返したい
こんにちは。 会社で写真台帳を作成しています。 以下の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
- 締切済み
- オフィス系ソフト
- 「複数の画像を挿入」の部分修正
過去ログから、失礼致します。 下記、コードを修正したいのですがどこを修正すればよいか分からないので ご教示願います。 1、ファイル名表示を、アドレス部分(C:\~)と拡張子部分を除いての表記にしたい。 2、縦4×横2の台帳なので横2列に対応するものに変更したい。 (縦4×横1であれば対応セルを変更すればよいのですが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("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 -----------------------------------------
- 締切済み
- Visual Basic
- エクセル マクロで困っています。画像がずれます。
御質問させて頂きます。 エクセルで、マクロを使って画像を貼り込んでいます。 初心者ながらにいろいろ調べまして、マクロを使って、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(1).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
- 締切済み
- オフィス系ソフト
- 画像をエクセルに貼り付けるマクロ
画像をエクセルに貼り付けるマクロ 複数の画像をエクセルに貼り付ける機会が多く、下記のマクロを利用しています。これは他人が作ったものでその人が今はいないため修正の仕方がわかりません。 これだとヨコに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
- ベストアンサー
- オフィス系ソフト
- マクロを実行すると画像がズレてしまいます
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製品
- excel マクロ 画像貼り付け位置入力
このマクロを使って別々のシートにセル位置A1から縦に 画像を挿入したいのですが ' 貼り付け開始セルを選択 ←マクロのプログラム部分 Range("A1").Select のA1の部分をこのマクロを起動させたら excel画面内に 四角 [ ] のボックスなどで表示させ 例 貼り付け指定位置を入力せよ A=[ ] などと表示させ それに例えば A=[ 5 ] [ 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
- 締切済み
- その他(プログラミング・開発)
- AddPictureで複数の画像を挿入したい
エクセル2010で下のようなコードでPictures.InsertとFor文を使用して複数の画像を読み込んでます。 ところが、Pictures.Insertを2010で使用すると画像がリンク貼付されてしまうため、エクセル2003で画像を見ることができません。そこで、AddPictureを使用しなければならないということは理解したのですが、ネット上のサンプルコードは1つのファイルを読み込む場合のものばかりで、今まで通りに複数の画像を読み込むためのコードがなかなかみつかりません。しかしながら、会社には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
- ベストアンサー
- オフィス系ソフト