https://drive.google.com/file/d/16JHl5YIba-LyDeEGro84w7p7W54RtLiD/view?usp=drive_link
Sub ファイル情報取得()
Dim フォルダパス As String
Dim ファイル名 As String
Dim 行番号 As Integer
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
' アクティブシート上のA1セルからフォルダパスを取得
フォルダパス = Range("A1").Value
' FileSystemObjectを作成
Set objFSO = CreateObject("Scripting.FileSystemObject")
' フォルダが存在するかチェック
If objFSO.FolderExists(フォルダパス) Then
' フォルダが存在する場合
' フォルダオブジェクトを取得
Set objFolder = objFSO.GetFolder(フォルダパス)
' ファイル情報を記入する行番号を初期化
行番号 = 1
' シート上のセルにファイル情報を記入
For Each objFile In objFolder.Files
行番号 = 行番号 + 1
' ファイル名を取得
ファイル名 = objFile.Name
' ファイルの作成日時を取得
Dim 作成日時 As Date
作成日時 = objFile.DateCreated
' ファイルの更新日時を取得
Dim 更新日時 As Date
更新日時 = objFile.DateLastModified
' ファイル情報をセルに記入
Cells(行番号, 2).Value = ファイル名
Cells(行番号, 3).Value = 作成日時
Cells(行番号, 4).Value = 更新日時
Next objFile
Else
' フォルダが存在しない場合
MsgBox "指定されたフォルダが見つかりません。", vbExclamation
End If
' オブジェクトを解放
Set objFSO = Nothing
Set objFolder = Nothing
Set objFile = Nothing
End Sub
Sub ファイルログ初期化()
'
' Macro4 Macro
'
'
Range("B2:D1048576").Select
Selection.ClearContents
Range("A1").Select
End Sub
Sub フィルター適用と更新日時で降順並び替え()
'
' フィルター適用と更新日時で降順並び替え Macro
'
'
Range("B1:D1").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("ファイル情報ログ").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ファイル情報ログ").AutoFilter.Sort.SortFields.Add2 Key:= _
Range("D1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("ファイル情報ログ").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
End Sub
Sub InsertImages()
Dim folderPath As String
Dim fileNameRange As Range
Dim cell As Range
Dim ws As Worksheet
Dim img As Picture
Dim imgCount As Integer
Dim i As Integer
Dim imageCell As Range
Sheets("ファイル情報ログ").Select
' A1に入力されているフォルダパスを取得
folderPath = Range("A1").Value
' シート「スクリーンショット貼り付け」を取得
Set ws = ThisWorkbook.Sheets("スクリーンショット貼り付け")
' B2からB5に入力されているファイル名を取得するためのセル範囲を指定
Set fileNameRange = Range("B2:B5")
' 貼り付ける画像の数を数える
imgCount = Application.WorksheetFunction.CountA(fileNameRange)
' 貼り付ける画像の数が4枚未満の場合、処理を終了する
If imgCount < 1 Or imgCount > 4 Then
MsgBox "ファイル名を4つ指定してください。"
Exit Sub
End If
' ファイル名ごとに処理を行う
For Each cell In fileNameRange
' セルが空でない場合のみ処理を行う
If cell.Value <> "" Then
' 画像を貼り付ける
Set img = ws.Pictures.Insert(folderPath & "\" & cell.Value)
' 画像をセルに合わせてサイズ変更
With img
.ShapeRange.LockAspectRatio = msoTrue
.Width = ws.Range("A1").Width
.Height = ws.Range("A1").Height
End With
' 画像を指定されたセル範囲に配置
Set imageCell = ws.Cells(5 - imgCount, 1)
img.Top = imageCell.Top
img.Left = imageCell.Left
' 画像をセル範囲の下に移動
imgCount = imgCount - 1
End If
Next cell
Sheets("スクリーンショット貼り付け").Select
End Sub
