Excel VBA のコードが作成できればお願い致します。


例えば、B1、D1、F1に対象フォルダ内の画像パスへハイパーリンクを貼り、
    C1、E1、G1に画像のサムネイルを取り込む

もしできれば、縦横比は保持して画像の入るセルのサイズは変更しない。

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

参考までにフォルダ内画像全てをExcelに取り込むVBAの記事を貼らせて頂きます。

Excel VBAで,フォルダ内の画像ファイルを一括でシートに取り込み,サムネイルのアルバムを自動生成
http://d.hatena.ne.jp/language_and_engineering/20131109/GenerateImageThumbnailAlbumByExcelVBA

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

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2017/09/22 12:46:08
  • 終了:2017/09/25 13:59:54

ベストアンサー

id:gfik No.1

いつか回答回数22ベストアンサー獲得回数102017/09/23 21:00:46

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

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
id: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


お手数をお掛けし申し訳ありません。

2017/09/25 09:53:18
id:gfik

必要なものができたのならよかったです。

2017/09/25 21:16:59

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません