例えば、B1、D1、F1に対象フォルダ内の画像パスへハイパーリンクを貼り、
C1、E1、G1に画像のサムネイルを取り込む
もしできれば、縦横比は保持して画像の入るセルのサイズは変更しない。
といった事が可能なのかどうか。
参考までにフォルダ内画像全てをExcelに取り込むVBAの記事を貼らせて頂きます。
Excel VBAで，フォルダ内の画像ファイルを一括でシートに取り込み，サムネイルのアルバムを自動生成
http://d.hatena.ne.jp/language_and_engineering/20131109/GenerateImageThumbnailAlbumByExcelVBA
何卒よろしくお願い申し上げます。
No.1
22
10
一応これで条件を満たしていると思います。
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
1
0
1
1
1
作成頂きありがとうございます！
2017/09/25 09:53:18ハイパーリンクが共有フォルダ故か、以下の部分でエラーになってしまう状況です。
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
お手数をお掛けし申し訳ありません。
必要なものができたのならよかったです。
2017/09/25 21:16:59