Excel VBA質問箱 IV

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

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


57239 / 76732 ←次へ | 前へ→

【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
0 hits

【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 お礼

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