Excel VBA のｺｰﾄﾞが作成できればお願い致します｡例えば､B1､D1､F1に対象ﾌｫﾙﾀﾞ内の画像ﾊﾟｽへﾊｲﾊﾟｰﾘﾝｸを貼り､ C1､E1､G1に画像のｻﾑﾈｲﾙを取り…

人力検索はてな

ﾓﾊﾞｲﾙ版を表示しています｡PC版はこちら

Excel VBA のｺｰﾄﾞが作成できればお願い致します｡

例えば､B1､D1､F1に対象ﾌｫﾙﾀﾞ内の画像ﾊﾟｽへﾊｲﾊﾟｰﾘﾝｸを貼り､
C1､E1､G1に画像のｻﾑﾈｲﾙを取り込む

もしできれば､縦横比は保持して画像の入るｾﾙのｻｲｽﾞは変更しない｡

といった事が可能なのかどうか｡

参考までにﾌｫﾙﾀﾞ内画像全てをExcelに取り込むVBAの記事を貼らせて頂きます｡

Excel VBAで，ﾌｫﾙﾀﾞ内の画像ﾌｧｲﾙを一括でｼｰﾄに取り込み，ｻﾑﾈｲﾙのｱﾙﾊﾞﾑを自動生成
http://d.hatena.ne.jp/language_and_engineering/20131109/GenerateImageThumbnailAlbumByExcelVBA

何卒よろしくお願い申し上げます｡

●質問者: siriustk
●ｶﾃｺﾞﾘ:ｺﾝﾋﾟｭｰﾀ
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

▽1 ● いつか

ﾍﾞｽﾄｱﾝｻｰ

一応これで条件を満たしていると思います｡

Sub test()
 Dim y As Integer, i As Integer
 Dim fileName As String
 Dim wPic As Double, hPic As Double
 Dim wCell As Double, hCell As Double
 Dim wRate As Double, hRate As Double
 
 For i = 0 To 2
 y = i * 2 + 2
 fileName = ActiveSheet.Cells(1, y).Value
 y = y + 1
 ActiveSheet.Cells(1, y).Select
 
 ActiveSheet.Pictures.Insert(fileName).Select
 Selection.Name = "pic" & y
 Set pic = ActiveSheet.Shapes("pic" & y)
 
 
 wPic = pic.Width
 hPic = pic.Height
 hCell = Rows(1).Height
 wCell = Columns(y).Width
 wRate = wPic / wCell
 hRate = hPic / hCell
 
 If wRate > hRate Then
 With pic
 .LockAspectRatio = True
 .Width = wCell
 End With
 Else
 With pic
 .LockAspectRatio = True
 .Height = hCell
 End With
 End If
 Next i
End Sub

siriustkさんのｺﾒﾝﾄ
作成頂きありがとうございます！ﾊｲﾊﾟｰﾘﾝｸが共有ﾌｫﾙﾀﾞ故か､以下の部分でｴﾗｰになってしまう状況です｡ ActiveSheet.Pictures.Insert(fileName).Select ちなみに別ｾﾙへ画像を貼り付けるのではなく､ﾊｲﾊﾟｰﾘﾝｸ該当ｾﾙに貼り付けるｺｰﾄﾞを見つけることが出来ましたので大変にありがたいのですが､何とか用を足せました｡ ' 選択したｾﾙに記載された画像ﾌｧｲﾙﾊﾟｽ(名)のﾌｧｲﾙを読み込み､EXCELに貼り付ける｡ ' Sub EggFunc_pasteImage() ' 変数定義 Dim filePath As String Dim targetCell As Range ' ｴﾗｰを無視する(画像ﾌｧｲﾙ読込み失敗時用) On Error Resume Next ' 選択したｾﾙ範囲を順次処理 For Each targetCell In Selection.Cells ' ｾﾙを選択 targetCell.Select ' 値があれば If targetCell.Value <> "" Then ' 画像ﾌｧｲﾙ名として取得 filePath = targetCell.Value ' 画像読込み ActiveSheet.Pictures.Insert(filePath).Select ' 画像が大きい場合､画像ｻｲｽﾞをｾﾙ幅に合わせる If Selection.Width > targetCell.Width Or Selection.Height > targetCell.Height Then If Selection.Width / targetCell.Width > Selection.Height / targetCell.Height Then Selection.Height = Selection.Height * (targetCell.Width / Selection.Width) Selection.Width = targetCell.Width Else Selection.Width = Selection.Width * (targetCell.Height / Selection.Height) Selection.Height = targetCell.Height End If End If ' 表示位置をｾﾙ右に移動 Selection.Top = targetCell.Top + (targetCell.Height - Selection.Height) Selection.Left = targetCell.Left + (targetCell.Width - Selection.Width) End If Next End Sub お手数をお掛けし申し訳ありません｡

いつかさんのｺﾒﾝﾄ
必要なものができたのならよかったです｡