Excel VBA質問箱 IV

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

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


10017 / 13646 ツリー ←次へ | 前へ→

【24228】ファイル一覧作成 あいんすと 05/4/16(土) 10:55 質問[未読]
【24229】Re:ファイル一覧作成 IROC 05/4/16(土) 11:35 回答[未読]
【24230】Re:ファイル一覧作成 Hirofumi 05/4/16(土) 12:18 回答[未読]
【24231】Re:ファイル一覧作成 Hirofumi 05/4/16(土) 12:20 回答[未読]
【24248】Re:ファイル一覧作成 Hirofumi 05/4/17(日) 9:06 回答[未読]
【24249】Re:ファイル一覧作成 あいんすと 05/4/17(日) 11:48 お礼[未読]

【24228】ファイル一覧作成
質問  あいんすと  - 05/4/16(土) 10:55 -

引用なし
パスワード
   とあるサイトから入力したアドレスのフォルダ内にあるファイル名を
エクセルにリストアップするマクロを入手したんですが、
これに、更新日時とサイズを記載する方法はありますか?

Private Sub CommandButton1_Click()

  Const cnsTITLE = "List file name in the folder"
  Const cnsDIR = "\*.*"
  Dim xlAPP As Application
  Dim strPATHNAME As String
  Dim strFILENAME As String
  Dim GYO, i As Long

  Set xlAPP = Application

  strPATHNAME = xlAPP.InputBox("Input folder address.", cnsTITLE, "C:\")


  If StrConv(strPATHNAME, vbUpperCase) = "FALSE" Then Exit Sub
  'check input
  If Dir(strPATHNAME, vbDirectory) = "" Then
    MsgBox "There is no input folder.", vbExclamation, cnsTITLE
    Exit Sub
  End If


Workbooks.Add

  Range("A1") = "No."
  Range("B1") = "File name"
  Range("A2:B65536") = ""

  GYO = 2

  'get top file name
  strFILENAME = Dir(strPATHNAME & cnsDIR, vbNormal)

  Do While strFILENAME <> ""
    Cells(GYO, 1) = GYO - 1
    Cells(GYO, 2).Value = strFILENAME
    strFILENAME = Dir()
    GYO = GYO + 1
  Loop
  Columns("A:B").Select
  Columns("A:B").EntireColumn.AutoFit


End Sub

【24229】Re:ファイル一覧作成
回答  IROC  - 05/4/16(土) 11:35 -

引用なし
パスワード
   >更新日時
FileDateTime 関数
指定したファイルの作成日時または最後に修正した日時を示す
バリアント型 (内部処理形式 Date の Variant) の値を返します。


>サイズ
FileLen 関数
ファイルのサイズをバイト単位で表す長整数型 (Long) の値を返します。


 以上です。

【24230】Re:ファイル一覧作成
回答  Hirofumi  - 05/4/16(土) 12:18 -

引用なし
パスワード
   Upされたコードの修正では有りませんが
私が現在使用中の、ファイル(Book)管理用のマクロをUpします
長すぎるので、先ずはUserFormのコードです

UserFormに以下のコントロールを配置して下さい
TextBox1 : 探索フォルダ表示
CheckBox1 : SubForderの探索指示
CommandButton1 : 終了
CommandButton2 : 参照
CommandButton3 : 更新
CommandButton4 : 行削除

以下をUserFormのコードモジュールに記述して下さい

Option Explicit
Option Compare Text

Private rngList As Range
Const clngColEnd As Long = 7

Private Sub UserForm_Activate()

  Dim vntFolder As Variant
  
  With TextBox1
    If .Text = "" Or Dir(.Text, vbDirectory) = "" Then
      vntFolder = GetFolderPath
      If vntFolder <> "" Then
        .Text = vntFolder
      End If
    End If
  End With
  
End Sub

Private Sub UserForm_Initialize()

  Set rngList = ActiveSheet.Cells(1, "A")
  
  CheckBox1 = True
  TextBox1.Text = rngList.Offset(1, 5).Value
  
End Sub

Private Sub UserForm_Terminate()

  Set rngList = Nothing
  
End Sub

Private Sub CommandButton4_Click()

  If MsgBox("存在しないFile名を削除します", vbExclamation _
          + vbOKCancel, "FileNameD Delete") = vbOK Then
    DataSheetSort rngList
    DeleteRows rngList
  End If

End Sub

Private Sub CommandButton1_Click()

  Unload Me
  
End Sub

Private Sub CommandButton2_Click()
  
  Dim vntFolder As Variant
  
  vntFolder = GetFolderPath
  If vntFolder <> "" Then
    TextBox1.Text = vntFolder
  End If
  
End Sub

Private Sub CommandButton3_Click()

  Dim vntFolder As Variant
  Dim blnDelete As Boolean
  
  vntFolder = TextBox1.Text
  If Dir(vntFolder, vbDirectory) = "" Then
    Beep
    MsgBox "フォルダが有りません", vbExclamation + vbOKOnly, "NoFolder"
    Exit Sub
  End If
  
  blnDelete = FileIndexMake(TextBox1.Text, CLng(CheckBox1.Value))
  
  DataSheetSort rngList
  
  If blnDelete Then
    If MsgBox("存在しないFile名が有りますので削除します", vbExclamation _
          + vbOKCancel, "FileNameD Delete") = vbOK Then
      DeleteRows rngList
    End If
  End If
  
End Sub

Private Function FileIndexMake(strDirPath As String, _
              Optional lngSubFolder As Long = -1) As Boolean

'  Const cstrExtend As String = ".xls"
  Const cstrExtend As String = ".*"
  
  Dim i As Long
  Dim lngRows As Long
  Dim vntKeyData As Variant
  Dim vntList As Variant
  Dim dicIndex As Object
  Dim vntDelete As Variant
  
  SetHeader rngList

  Set dicIndex = CreateObject("Scripting.Dictionary")

  vntKeyData = FilesList(strDirPath, "*" & cstrExtend, lngSubFolder)
  
  With rngList
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngRows > 0 Then
      vntList = .Offset(1).Resize(lngRows, clngColEnd).Value
      For i = 1 To lngRows
        dicIndex.Add vntList(i, 6) & vntList(i, 1), i
      Next i
    End If
  End With
    
  FilesCompare vntList, vntKeyData, dicIndex
  
  If VarType(vntList) <> vbEmpty Then
    Erase vntList
  End If
    
  CellsFormat rngList
  
  With dicIndex
    If .Count > 0 Then
      FileIndexMake = True
      vntDelete = .Items
    End If
    For i = 0 To .Count - 1
      rngList.Offset(vntDelete(i), 6).Value = "*"
    Next i
  End With
  
  Set dicIndex = Nothing
  
End Function

Private Sub FilesCompare(vntList As Variant, _
              vntKeyData As Variant, _
              dicIndex As Object)

  Dim i As Long
  Dim j As Long
  Dim vntKey As Variant
  Dim lngFound As Long
  Dim lngNewFile() As Long
  Dim dblStamp As Double
  Dim vntAppend As Variant
  Dim lngRows As Long
  
  If VarType(vntList) <> vbEmpty Then
    ReDim vntStamp(1 To UBound(vntList, 1), 1 To 3)
    With dicIndex
      j = 0
      For i = 0 To UBound(vntKeyData, 2)
        vntKey = vntKeyData(0, i) & vntKeyData(1, i)
        If .Exists(vntKey) Then
          lngFound = .Item(vntKey)
          vntStamp(lngFound, 1) = FileLen(vntKey) \ 1024
          dblStamp = CDbl(FileDateTime(vntKey))
          If vntList(lngFound, 5) <> "" Then
            If dblStamp <> CDbl(vntList(lngFound, 5)) Then
              vntStamp(lngFound, 2) = CDbl(vntList(lngFound, 5))
              vntStamp(lngFound, 3) = dblStamp
            Else
              If vntList(lngFound, 4) <> "" Then
                vntStamp(lngFound, 2) = CDbl(vntList(lngFound, 4))
                vntStamp(lngFound, 3) = CDbl(vntList(lngFound, 5))
              End If
            End If
          End If
          vntStamp(lngFound, 3) = dblStamp
          .Remove (vntKey)
        Else
          j = j + 1
          ReDim Preserve lngNewFile(1 To j)
          lngNewFile(j) = i
        End If
      Next i
    End With
    lngRows = UBound(vntStamp, 1)
    With rngList
      .Offset(1, 2).Resize(lngRows, _
              UBound(vntStamp, 2)).Value = vntStamp
    End With
  Else
    lngRows = 0
    j = UBound(vntKeyData, 2)
    ReDim lngNewFile(1 To j)
    For i = 1 To j
      lngNewFile(i) = i
    Next i
  End If
  
  If j > 0 Then
    ReDim vntAppend(1 To UBound(lngNewFile), 1 To 6)
    For i = 1 To UBound(lngNewFile)
      vntAppend(i, 1) = vntKeyData(1, lngNewFile(i))
      vntAppend(i, 3) = FileLen(vntKeyData(0, lngNewFile(i)) _
                  & vntKeyData(1, lngNewFile(i))) \ 1024
      vntAppend(i, 5) = CDbl(FileDateTime(vntKeyData(0, lngNewFile(i)) _
                  & vntKeyData(1, lngNewFile(i))))
      vntAppend(i, 6) = vntKeyData(0, lngNewFile(i))
    Next i
    With rngList
      .Offset(lngRows + 1).Resize(UBound(vntAppend, 1), _
              UBound(vntAppend, 2)).Value = vntAppend
    End With
  End If
  
End Sub

Private Sub SetHeader(rngTop As Range)

  Dim vntList As Variant

  With rngTop
    If .Value = "" Then
      vntList = Array("ファイル名", "備考", "サイズ(KB)", _
                  "前回更新", "更新日", "フォルダ", "NoFile")
      With .Resize(, UBound(vntList) + 1)
        .Value = vntList
        With .Interior
          .ColorIndex = 35
          .Pattern = xlSolid
          .PatternColorIndex = xlAutomatic
        End With
      End With
    End If
  End With

End Sub

Private Sub CellsFormat(rngTop As Range)

  Dim lngEnd As Long
  
  With rngTop
    lngEnd = .Offset(65536 - .Row).End(xlUp).Row - .Row
    With .Offset(1, 2).Resize(lngEnd)
      .NumberFormatLocal = "#,##0_ "
    End With
    With .Offset(1, 3).Resize(lngEnd, 2)
      .NumberFormatLocal = "yyyy/mm/dd hh:mm"
      .HorizontalAlignment = xlCenter
    End With
    .Parent.Columns.AutoFit
  End With
  
End Sub

【24231】Re:ファイル一覧作成
回答  Hirofumi  - 05/4/16(土) 12:20 -

引用なし
パスワード
   つづき
以下を標準モジュールに記述して下さい

Option Explicit

' アクティブなウィンドウのハンドルを取得する関数の宣言
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long

Public Function GetFolderPath() As String

  Dim strTitle As String
  Dim objFolder As Object
  Dim hWnd As Long
  Dim strTmpPath As String
  Const BIF_RETURNONLYFSDIRS = &H1
  Const ssfDESKTOP = &H0
  Const CSIDL_WINDOWS = &H24
  
  'アクティブなWindowのハンドルを取得
  hWnd = GetForegroundWindow
  ' 表示タイトルを指定
  strTitle = "フォルダを選択して下さい"
  ' フォルダ選択ダイアログを表示
  Set objFolder = CreateObject("Shell.Application"). _
              BrowseForFolder(hWnd, strTitle, _
                BIF_RETURNONLYFSDIRS, CSIDL_WINDOWS)
  ' フォルダを選択したときは
  If Not (objFolder Is Nothing) Then
    ' 選択フォルダを表示
    With objFolder
      ' 親フォルダが存在するときは
      If Not (.ParentFolder Is Nothing) Then
        ' 選択フォルダのフルパスを表示
        strTmpPath = .Items.Item.Path
      ' 親フォルダのときは
      Else
        ' フォルダ名を表示
        strTmpPath = .Title
      End If
    End With
    ' Folderオブジェクトを破棄
    Set objFolder = Nothing
  End If
  
  If strTmpPath <> "" And Right(strTmpPath, 1) <> "\" Then
    strTmpPath = strTmpPath & "\"
  End If

  GetFolderPath = strTmpPath
  
End Function

Public Function FilesList(ByVal strFolderPath As String, _
            ByVal strSearchFile As String, _
            Optional lngSubDir As Long = -1) As Variant

  Dim i As Long
  Dim j As Long
  Dim strFolders() As String
  Dim strFILENAME As String
  Dim strFileNames() As String
  
  'パスの最後に\を付加
  If Right(strFolderPath, 1) <> "\" Then
    strFolderPath = strFolderPath & "\"
  End If
    
  'フォルダのListを作成
  ReDim strFolders(0)
  '探し始めるフォルダを代入
  strFolders(0) = strFolderPath
  'フォルダをリストアップ
  If lngSubDir <> 0 Then
    GetFolders strFolderPath, strFolders(), _
            UBound(strFolders) + 1, lngSubDir
  End If
  
  j = 0
  ReDim strFileNames(1, j)
  For i = 0 To UBound(strFolders)
    'ディレクトリ内の全ての標準ファイルを列挙
    strFILENAME = Dir(strFolders(i) & strSearchFile)
    Do Until strFILENAME = ""
      ReDim Preserve strFileNames(1, j)
      strFileNames(0, j) = strFolders(i)
      strFileNames(1, j) = strFILENAME
      j = j + 1
      strFILENAME = Dir
    Loop
  Next i
    
  FilesList = strFileNames()
  
End Function

Public Function FoldersList(ByVal strFolderPath As String, _
            Optional lngSubDir As Long = -1) As Variant

'  strFolderPath:  探し始めるフォルダ名
'  lngSubDir:   探す階層数

  Dim strFolders() As String

  'パスの最後に\を付加
  If Right(strFolderPath, 1) <> "\" Then
    strFolderPath = strFolderPath & "\"
  End If

  ReDim strFolders(0)
  '探し始めるフォルダを代入
  strFolders(0) = strFolderPath
  'フォルダをリストアップ
  If lngSubDir <> 0 Then
    GetFolders strFolderPath, strFolders(), _
            UBound(strFolders) + 1, lngSubDir
  End If

  FoldersList = strFolders()

End Function

Private Sub GetFolders(ByVal strFilesPath As String, _
              strDirList() As String, _
              lngNextData As Long, _
              lngSubDir As Long)

  Dim i As Long
  Dim j As Long
  Dim lngNow As Long
  Dim strFILENAME As String

  '結果用配列の書き込み位置を取得
  i = lngNextData
  
  'サブディレクトリの結果リストと、一時的なリストを作成
  strFILENAME = Dir(strFilesPath, vbDirectory)
  Do Until strFILENAME = ""
    '現在のディレクトリと親ディレクトリを無視
    If strFILENAME <> "." And strFILENAME <> ".." Then
      'ディレクトリ以外を無視
      If GetAttr(strFilesPath & strFILENAME) _
                    And vbDirectory Then
        ReDim Preserve strDirList(i)
        '結果リストに追加
        strDirList(i) = strFilesPath & strFILENAME & "\"
        i = i + 1
      End If
    End If
    strFILENAME = Dir
  Loop
  
  j = lngNextData
  lngNextData = i
  'ディレクトリの階層を一つ下げる
  lngSubDir = lngSubDir - 1
  
  '指定階層数になるまで再帰、lngSubDir < 0 の時は最終階層まで再帰
  If lngSubDir > 0 Or lngSubDir < 0 Then
    '各ディレクトリを再帰的に処理
    For i = j To lngNextData - 1
      lngNow = lngSubDir
      GetFolders strDirList(i), strDirList(), _
                      lngNextData, lngNow
    Next i
  End If

End Sub

Public Sub DeleteRows(rngTop As Range)

  Dim lngDelEnd As Long
  Dim lngDelTop As Long
  
  With rngTop
    lngDelEnd = .Offset(65536 - .Row, 6).End(xlUp).Row - .Row
    If lngDelEnd < 1 Then
      Exit Sub
    End If
  End With
  
  lngDelTop = 1
  With rngTop
    Range(.Offset(lngDelTop), .Offset(lngDelEnd)).EntireRow.Delete
  End With
    
End Sub

Public Sub DataSheetSort(rngTop As Range)

  With rngTop.CurrentRegion
    .Sort Key1:=.Item(1, 7), Order1:=xlAscending, _
        Key2:=.Item(1, 6), Order2:=xlAscending, _
        Key3:=.Item(1, 1), Order2:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, _
        SortMethod:=xlPinYin
  End With

End Sub

Public Sub BookOpen(ByVal strTarget As String)

  If Dir(strTarget) <> "" Then
    Workbooks.Open (strTarget)
  End If
  
End Sub

Public Sub IndeFormShow()

  ActiveCell.Activate
  
  UserForm1.Show
  
End Sub

以下をThisWorkBookのコードモジュールに記述して下さい

Private Sub Workbook_Open()

  IndeFormShow
  
End Sub

【24248】Re:ファイル一覧作成
回答  Hirofumi  - 05/4/17(日) 9:06 -

引用なし
パスワード
   ゴメン本題の方は、以下の様かな?

Option Explicit

Public Sub Sample()

  Const cnsTITLE = "List file name in the folder"
  Const cnsDIR = "\*.*"
  
  Dim i As Long
  Dim lngRow As Long
  Dim vntPATHNAME As Variant
  Dim strFileName As String
  Dim vntResult As Variant
  
  vntPATHNAME = Application.InputBox("Input folder address.", cnsTITLE, "C:\")

  If VarType(vntPATHNAME) = vbBoolean Then
    Exit Sub
  Else
    If Right(vntPATHNAME, 1) <> "\" Then
      vntPATHNAME = vntPATHNAME & "\"
    End If
  End If
  
  'check input
  If Dir(vntPATHNAME, vbDirectory) = "" Then
    MsgBox "There is no input folder.", vbExclamation, cnsTITLE
    Exit Sub
  End If

  ReDim vntResult(1 To 4)
  
  With Workbooks.Add.Worksheets(1)
  lngRow = 1
  .Cells(lngRow, "A").Resize(, 4).Value _
      = Array("No.", "FileName", "DateTime", "Size(KB)")
  lngRow = lngRow + 1
    'get top file name
    strFileName = Dir(vntPATHNAME & cnsDIR, vbNormal)
    Do While strFileName <> ""
      vntResult(1) = lngRow - 1
      vntResult(2) = strFileName
      vntResult(3) _
          = Format(CDate(FileDateTime(vntPATHNAME & strFileName)), _
                              "yyyy/mm/dd h:mm:ss")
      vntResult(4) = FileLen(vntPATHNAME & strFileName) \ 1024
      .Cells(lngRow, "A").Resize(, 4).Value = vntResult
      lngRow = lngRow + 1
      strFileName = Dir
    Loop
    .Cells.EntireColumn.AutoFit
  End With
    
End Sub

【24249】Re:ファイル一覧作成
お礼  あいんすと  - 05/4/17(日) 11:48 -

引用なし
パスワード
   お礼が遅れましたが、
いろいろな回答ありがとうございます。

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