Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

3998 / 76734

←次へ　｜　前へ→


	【78364】特定のセルの写真を削除してから挿入

acs - 16/7/27(水) 11:43 -


	引用なし

	パスワード

初めに長文にて失礼いたします

Ａ１に入っている写真を一旦削除（無ければスルー）してから、写真を選択し縮小してから張り付ける。なお写真はリンクにならないようする。

というようなマクロを作りたいのですがどうしたらよいのでしょうか？

以前、色々なＨＰなどを見てエクセル2003で作成したのですが、写真を選択し縮小してから張り付けるまではできたのですが、エクセル2010にしたところ、同じフォルダにないと写真が「リンク...」と表示されるようになってしまいました。
さらに違うＰＣでマクロを動かすと、写真のサイズが微妙に変わってしまうのです。

せっかくなので、
1.Ａ１に写真があれば、一旦削除
2.リンク表示をなくす
の機能を追加して新たに作成ということで今回も様々なＨＰなどを検索してみたのですが、うまくできませんでした。

（以前のマクロ）
Sub Acespic1()

　　Dim FName As String
　　Dim myPct As Object
　　
　　FName = Application.GetOpenFilename(FileFilter:="JPG形式(*.jpg),*.jpg", Title:="ファイルを選択してください")
　　
　　If FName = "False" Then Exit Sub
　　
　　Range("A1").Select
　　
　　Set myPct = ActiveSheet.Pictures.Insert(FName)
　　　　
　　　　
　　With myPct.ShapeRange
　　　　.LockAspectRatio = msoTrue
　　　　.Height = 255
　　　　.IncrementTop 3.75
　　　　
　　　　
　　End With
　　
End Sub

（とあるＨＰから見つけたマクロ）
複数選択でき、リンク表示もされないため、すごく良かったのですが、削除のマクロを追加したいのと、縮小した写真がぼやけてしまいます。一旦保存して再度開くくと綺麗な写真になるのですが…

丸々の流用なのでとあるＨＰの回答者様に失礼かもしれませんが、下記の通りです

'図をリンクオブジェクトではなく図として挿入する
'Pictures.Insert メソッドではなく、Shapes.Add メソッドを使用
Sub 複数の画像を挿入01()
Dim strFilter As String
Dim Filenames As Variant
Dim objShape As Shape
Dim i As Integer

' 「ファイルを開く」ダイアログでファイル名を取得
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("A2").Select

' マクロ実行中の画面描写を停止
Application.ScreenUpdating = False

' 順番に画像を挿入
For i = LBound(Filenames) To UBound(Filenames)
Set objShape = ActiveSheet.Shapes.AddPicture( _
Filenames(i), False, True, Selection.Left, Selection.Top, 50#, 50#)
'-------------------------------------------------------------
' 画像の各種プロパティ変更
'-------------------------------------------------------------
With objShape
.ScaleHeight 1!, msoTrue
.ScaleWidth 7!, msoTrue
.Height = ActiveCell.MergeArea.Height
.Placement = xlMove ' 移動するがサイズ変更しない
End With
' 次の貼り付け先を選択（アクティブセルにする）[例：2個下のセル]
ActiveCell.Offset(2).Select
Set objShape = Nothing
Next i

' 終了
Application.ScreenUpdating = True
MsgBox UBound(Filenames) & "枚の画像を挿入しました", vbInformation
End Sub

' バブルソート（文字列） 'ORIGINAL
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

6 hits

▼

【78364】特定のセルの写真を削除してから挿入 acs 16/7/27(水) 11:43