ファイル検索

Sub select_Click()

    Dim sheetA As Worksheet
    Dim Shell, myPath
    
    Set sheetA = ActiveSheet
    
    
    Set Shell = CreateObject("Shell.Application")
    Set myPath = Shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10)
    
    If Not myPath Is Nothing Then
        sheetA.Cells(3, 2).Value = myPath.Items.Item.path
    End If
    
    Set Shell = Nothing
    Set myPath = Nothing

End Sub


Sub copy_Click()
    Dim sheetA As Worksheet
    Dim strNow As String
    Dim cnt As Long
    Dim i As Long
    
    cnt = 0
    Set sheetA = ActiveSheet
    
    For i = 7 To 60000
        If sheetA.Cells(i, 2).Value = "" Then
            cnt = i - 1
            Exit For
        End If
    Next i
    
    strNow = Format(Now, "yyyymmdd_hhnnss")

    Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = strNow
    Set sheetDeki = Sheets(strNow)
    
    sheetA.Range("A7:F" & i).Copy sheetDeki.Range("A1:F" & (i - 6))
    
    sheetDeki.Columns(1).ColumnWidth = 7
    sheetDeki.Columns(2).ColumnWidth = 60
    sheetDeki.Columns(3).ColumnWidth = 30
    sheetDeki.Columns(4).ColumnWidth = 20
    sheetDeki.Columns(5).ColumnWidth = 10
    sheetDeki.Columns(6).ColumnWidth = 20

End Sub

Sub clear_Click()

    Dim sheetA As Worksheet
    
    Set sheetA = ActiveSheet
    
    Call clearAll(sheetA)
    
    MsgBox "クリアしました"

End Sub

Private Function clearAll(sheetA As Worksheet)

    Dim cnt As Long
    Dim i As Long
    

    cnt = 0

    For i = 7 To 60000
    
        If sheetA.Cells(i, 2).Value = "" Then
            
            cnt = i - 1
            Exit For
        End If
    Next i
    
    sheetA.Range(Cells(8, 1), Cells(i, 6)).Clear
    
    Application.DisplayAlerts = False
    
        If ExistsWorksheet("参照不可フォルダ") Then
            Sheets("参照不可フォルダ").Delete
        End If
    Application.DisplayAlerts = True
    
End Function




Sub ref2_Click()

End Sub
Sub serach3_Click()
    
    Dim sheetA As Worksheet
    Dim sheetNG As Worksheet
    Dim path As String
    Dim cnt As Long
    Dim errCnt As Long
    Dim fso As Object
    
    cnt = 0
    errCnt = 2
    
    Set sheetA = ActiveSheet
    
    Call clearAll(sheetA)
    
    Worksheets.Add(Before:=Worksheets(1)).name = "参照不可フォルダ"
    Set sheetNG = Sheets("参照不可フォルダ")
    
    sheetNG.Cells(1, 1).Value = "参照不可フォルダ"
    
    sheetA.Activate
    
    path = sheetA.Cells(3, 2).Value
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Call search(fso, sheetA, sheetNG, path, cnt, errCnt)
    
    If errCnt = 2 Then
        Application.DisplayAlerts = False
        Sheets("参照不可フォルダ").Delete
        Application.DisplayAlerts = True
        sheetA.Activate
    End If
    
    MsgBox "検索が完了しました"
    
End Sub

Sub search(fso As Object, sheetA As Worksheet, sheetNG As Worksheet, path As String, cnt As Long, errCnt As Long)
    
    Dim folderObj As Object
    
    If cnt > 60000 Then
    
        MsgBox "検索対象が60000件を超えています"
    Else
        On Error GoTo ErrLabel
    
        Set folderObj = fso.GetFolder(path)
        

        
        For Each objFILE In folderObj.Files
            cnt = cnt + 1
            
            With objFILE
                sheetA.Cells(cnt + 7, 1).Value = cnt
                sheetA.Cells(cnt + 7, 2).Value = .ParentFolder
                sheetA.Cells(cnt + 7, 3).Value = .name
                sheetA.Cells(cnt + 7, 4).Value = .Type
                sheetA.Cells(cnt + 7, 5).Value = .Size
                sheetA.Cells(cnt + 7, 6).Value = .DateLastModified
            
            End With
            
            
        Next objFILE
        
        
        For Each objPATH2 In folderObj.SubFolders
        
            Call search(fso, sheetA, sheetNG, objPATH2.path, cnt, errCnt)
        Next objPATH2
    
    End If
    
    Exit Sub
    
ErrLabel:
    If Not (folderObj Is Nothing) Then
        sheetNG.Cells(errCnt, 1).Value = folderObj.path
    Else
        sheetNG.Cells(errCnt, 1).Value = path & "存在しない"
    End If
    errCnt = errCnt + 1
    sheetA.Activate
End Sub

Private Function ExistsWorksheet(ByVal name As String)

    Dim ws As Worksheet
    For Each ws In Sheets
        If ws.name = name Then
            ' 存在する
            ExistsWorksheet = True
            Exit Function
        End If
    Next
    
    ' 存在しない
    ExistsWorksheet = False
End Function