Created
July 21, 2018 13:15
-
-
Save privatejk2002/8b3951241ebfc96c30ac4e81e6817a72 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment