| |
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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
