Excel VBA質問箱 IV

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

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


16784 / 76732 ←次へ | 前へ→

【65412】複数画像を挿入時に任意セルにファイル名を入力したい
質問  to  - 10/5/19(水) 12:18 -

引用なし
パスワード
   現在、写真帳を作成しているのですが大量にあるため自動で作成できるよう、
よく似たパターンのモジュールをネットから検索し、画像を貼り付けるまでは
できたのですが、挿入時画像の下のセルに
写真N0(01から昇順)とファイル名(拡張子無)を入力したいと思っています。
VBA初心者の為、どうしたらいいか分からず質問させていただきました。
どうかご教授願います。

↓作成したいフォーマット
写真No:の隣のセルに01から昇順の番号
部位:の隣のセルにファイル名
を入力したいと思っています。


―――――― ――――――
  
  画像1    画像2

―――――― ――――――
写真No:    写真No:
部位:     部位:

―――――― ――――――
  
  画像3    画像4

―――――― ――――――
写真No:    写真No:
部位:     部位:

―――――― ――――――
  
  画像5    画像6

―――――― ――――――
写真No:    写真No:
部位:     部位:


↓モジュールです

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

' バブルソート(文字列)
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 hits

【65412】複数画像を挿入時に任意セルにファイル名を入力したい to 10/5/19(水) 12:18 質問
【65420】Re:複数画像を挿入時に任意セルにファイル... mura 10/5/19(水) 16:52 回答
【65422】Re:複数画像を挿入時に任意セルにファイル... to 10/5/19(水) 18:21 お礼
【65424】Re:複数画像を挿入時に任意セルにファイル... mura 10/5/20(木) 0:15 発言
【65432】Re:複数画像を挿入時に任意セルにファイル... to 10/5/20(木) 12:12 お礼

16784 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free