VBA Ãþ¦üdirªº¥\¯à

millerch

½Ð±Ð½Ñ¦ì¥ý¶i

Set oFolder = oFSO.GetFolder("D:\file\") ¥iÅã¥Üfile¥Ø¿ý¤º©Ò¦³ªºÀÉ®×
¦ý­Y¥u­n¥X²{ªþÀɦW¬°*.xlsm¤§ÀɮסA½Ð°Ý­n¦p¦ó§ï? ÁÂÁÂ

Andy2483

¦^´_ 1# millerch


    ÁÂÁ«e½úµoªí¦¹¥DÃD
GetExtensionName ¤èªk ,·|¶Ç¦^¥]§t¸ô®|¤¤³Ì«á¤@­Ó¤¸¥óªº°ÆÀɦWªº¦r¦ê¡C
https://learn.microsoft.com/zh-tw/office/vba/language/reference/user-interface-help/getextensionname-method

millerch

¦^´_ 2# Andy2483
ÁÂÁ«e½ú¦^ÂÐ
§ÚVBA
' «Ø¥ß¥Ø¿ýª«¥ó
Set oFolder = oFSO.GetFolder("D:\Dropbox\Swap\")
§Ú¤£ª¾¦p¦ó²£¥ÍÃþ¦ü
Set oFolder = oFSO.GetFolder("D:\Dropbox\Swap\*.xlsmªº®ÄªG")   

§Úµ{¦¡¦p¤U
Sub FM()
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i, j As Integer
RegexKill "D:\Dropbox\Swap\", "^[~]+.xlsm"
' «Ø¥ß FileSystemObject ª«¥ó
Set oFSO = CreateObject("Scripting.FileSystemObject")
' «Ø¥ß¥Ø¿ýª«¥ó
Set oFolder = oFSO.GetFolder("D:\Dropbox\Swap\")
i = 4
j = 3
' ¥H°j°é¦C¥X©Ò¦³ÀÉ®×
For Each oFile In oFolder.Files
    If Left(oFile.name, 1) <> "~" Then
    Cells(i, j) = oFile.name              ' ÀɮצWºÙ
    j = j + 1
    'Cells(i, j) = oFile.Path              ' Àɮ׸ô®|
    ' j = j + 1
    Cells(i, j) = oFile.Size              ' Àɮפj¤p¡]¦ì¤¸²Õ¡^
     j = j + 1
    'Cells(i, j) = oFile.Type              ' ÀÉ®×Ãþ«¬
    ' j = j + 1
    Cells(i, j) = oFile.DateCreated       ' Àɮ׫إ߮ɶ¡
     j = j + 1
    'Cells(i, j) = oFile.DateLastAccessed  ' ÀɮפW¦¸¦s¨ú®É¶¡
    ' j = j + 1
    Cells(i, j) = oFile.DateLastAccessed  ' ÀɮפW¦¸­×§ï®É¶¡

    i = i + 1
    j = 3
    End If

Next oFile
End Sub

Andy2483

¦^´_ 3# millerch


    ÁÂÁ«e½ú¦^´_

Application.GetOpenFilename ¤èªk (Excel)

¤U¸ü (69.66 KB)

2023-1-4 11:43

Option Explicit
Sub TEST_OpenFile()
Dim FileFilter As String
Dim file_Open
FileFilter = "Excel Files(*. xlsm*),"
file_Open = Application.GetOpenFilename(FileFilter, 1, "½Ð¿ï¾Ü¤å¥ó")
'https://learn.microsoft.com/zh-tw/office/vba/api/excel.application.getopenfilename
If file_Open = False Then
   MsgBox "¨S¦³¿ï¾Ü¤å¥ó", vbOKOnly, "´£¥Ü"
   Exit Sub
   Else
      Workbooks.Open Filename:=file_Open
End If
End Sub

Andy2483

¦^´_ 3# millerch


    ¦pªG¬O­n¸ê®Æ§¨Àɮשú²Ó! ³o¬O ­ã´£³¡ªL«e½úªº¤èªk

°õ¦æ«e:

¤U¸ü (94.37 KB)

2023-1-4 11:53

°õ¦æµ²ªG:

¤U¸ü (285.09 KB)

2023-1-4 11:51

Sub ²M°£()
Dim y&, z&
With ActiveSheet
     If .AutoFilterMode Then .AutoFilterMode = False
     y = .UsedRange.Rows.Count
     z = .[Uhead].Row + 1
     If y > z Then .Rows(z + 1 & ":" & y).EntireRow.Delete
     .Rows(z).ClearContents
     .[Uhead].Cells(2).Resize(1, 2) = Array("¡½", "¥»¦C½Ð¤Å§R°£")
End With
ActiveWindow.ScrollRow = 1
End Sub

Sub ¸ü¤JÀÉ®×()
Dim MyPath, uPath, xD1, xD2, Urr, UU, OBJ, GFD, UFD, GFL, UFL, GG
Dim j&, Jm&, k&, Km&, x, Xm, ExName$, XX$, Arr, VV$, CCunt&, UCunt&
Call ²M°£:  MyPath = ThisWorkbook.FullName
uPath = [B1]
If uPath = "" Then MsgBox "¸ô®|¥¼¿é¤J!": Exit Sub
If [B1] = "MyPath" Then uPath = ThisWorkbook.Path
If Dir(uPath, vbDirectory) = "" Then MsgBox "§ä¤£¨ì¸ô®|!": Exit Sub
If [B2] = "" Then MsgBox "°ÆÀɦW¥¼¿é¤J!": Exit Sub
ExName = "," & UCase([B2]) & ",": If [B2] = "*.*" Then ExName = "1"
'----------------------------------------
[E4] = "¡ã¡ã¥¿¦bÂ^¨úÀɮשú²Ó¡A°õ¦æ¤¤¥i«öESC¤¤¤î¡ã¡ã"
Application.EnableCancelKey = xlErrorHandler
Set OBJ = CreateObject("Scripting.FileSystemObject")
Set xD1 = CreateObject("Scripting.Dictionary")
Set xD2 = CreateObject("Scripting.Dictionary")
Urr = Array(uPath)
RE_GET:
On Error GoTo 999
For Each UU In Urr
    If Len(UU) < 3 Then
       Set GFD = OBJ.GetDrive(UU)
       VV = UCase(UU)
       Set UFD = GFD.RootFolder.SubFolders
       Set GFL = GFD.RootFolder.Files
    Else
       Set GFD = OBJ.GetFolder(UU)
       VV = GFD.Name:   SZ = 0
       Set UFD = GFD.SubFolders
       Set GFL = GFD.Files
    End If
    '-------------------------------
    k = 0: Xm = 0: UCunt = 0
    On Error Resume Next
       UCunt = GFL.Count '¹J¨ì¡eSystem Volume Information¡f·|¿ù»~
    On Error GoTo 999
    If UCunt = 0 Then GoTo GET_SubFolder
    For Each GG In GFL
        If GG.Path = MyPath Then GoTo 101
        XX = UCase(OBJ.GetExtensionName(GG.Path))
        If XX = "" Then XX = "¥¼ª¾"
        If ExName = "1" Then j = 1 Else j = InStr(ExName, "," & XX & ",")
        If j = 0 Then GoTo 101
        Jm = Jm + 1: k = 1
        x = GG.Size / 1024: Xm = Xm + x
        xD1(Jm) = Array(GG.Name, XX, x, UU & "\")
        Application.StatusBar = "¡½¡½¡½¥¿¦bÂ^¨úÀɮצWºÙ¡G(" & Jm & ")" & GG.Name
101: Next
    If k = 1 Then Jm = Jm + 1: xD1(Jm) = Array("¢@" & VV & "¢@", "", Xm, UU)
   '----------------------------------------------
GET_SubFolder:
    UCunt = 0
    On Error Resume Next
       UCunt = UFD.Count '¹J¨ì¡eSystem Volume Information¡f·|¿ù»~
    On Error GoTo 999
    If UCunt > 0 Then
       For Each GG In UFD
           Km = Km + 1: xD2(Km) = GG.Path
       Next
    End If
Next
CCunt = CCunt + 1
If Val([C4]) > 0 Then If CCunt >= [C4] Then Km = 0
If Km > 0 Then Urr = xD2.items: xD2.RemoveAll: Km = 0: GoTo RE_GET
'---------------------------------------
If Jm = 0 Then MsgBox "§ä¤£¨ì²Å¦XÀɮסI": GoTo 999
If Jm > Rows.Count - 1 Then MsgBox "Àɮשú²Ó¶W¹L¤u§@ªí¥i®e¯Ç¦C¼Æ¡I": GoTo 999
Application.StatusBar = "¡½¡½¡½¸ü¤J¤Î¾ã²z¸ê®Æ¤¤¡D¡D¡D¡D¡D"
ReDim Arr(Jm - 1, 3): k = 0
For Each UU In xD1.items
    Arr(k, 0) = UU(0): Arr(k, 1) = UU(1)
    Arr(k, 2) = UU(2): Arr(k, 3) = UU(3): k = k + 1
Next
With [Uhead].Cells(2, 1).Resize(Jm, 5)
     .Rows(1).Copy .Cells
     .Item(2).Resize(Jm, 4) = Arr
     .Sort Key1:=.Item(2), Order1:=xlAscending, Header:=xlNo
     .Sort Key1:=.Item(5), Order1:=xlAscending, Header:=xlNo
     .Columns(1).FormulaR1C1 = "=IF(RC[2]="""",HYPERLINK(RC[4],""¡½""),N(R[-1]C)+1)"
End With
[D1] = "=SUMIF(A7:A" & Jm + 6 & ","">0"",D7:D" & Jm + 6 & ")"
999: [E4] = "": Application.StatusBar = False
End Sub

Sub ¸ü¤J¸ê®Æ§¨()
Dim uPath, xD1, xD2, Urr, UU, OBJ, GFD, UFD, GG
Dim j&, Jm&, k&, Km&, Arr, VV$, SZ, CCunt&, UCunt&
Call ²M°£:   uPath = [B1]
If uPath = "" Then MsgBox "¸ô®|¥¼¿é¤J!": Exit Sub
If [B1] = "MyPath" Then uPath = ThisWorkbook.Path
If Right(uPath, 1) = "\" Then uPath = Left(uPath, Len(uPath) - 1)
If Dir(uPath, vbDirectory) = "" Then MsgBox "¸ô®|¿ù»~¡I": Exit Sub
'----------------------------------------
[E4] = "¡ã¡ã¥¿¦bÂ^¨ú¸ê®Æ§¨¡A°õ¦æ¤¤¥i«öESC°±¤î¡ã¡ã"
Application.EnableCancelKey = xlErrorHandler
Set OBJ = CreateObject("Scripting.FileSystemObject")
Set xD1 = CreateObject("Scripting.Dictionary")
Set xD2 = CreateObject("Scripting.Dictionary")
Urr = Array(uPath)
RE_GET:
On Error GoTo 999
For Each UU In Urr
    If Len(UU) < 3 Then
       Set GFD = OBJ.GetDrive(UU)
       VV = UCase(UU)
       SZ = GFD.TotalSize - GFD.FreeSpace
       Set UFD = GFD.RootFolder.SubFolders
    Else
       Set GFD = OBJ.GetFolder(UU)
       VV = GFD.Name: SZ = 0
       On Error Resume Next
          SZ = GFD.Size           '¹J¨ì¡eSystem Volume Information¡f·|¿ù»~
       On Error GoTo 999
       Set UFD = GFD.SubFolders
    End If
   
    Jm = Jm + 1: xD1(Jm) = Array("¢@" & VV & "¢@", "Folder", SZ / 1024, UU)
    Application.StatusBar = "¡½¡½¡½¥¿¦bÂ^¨ú¸ê®Æ§¨¦WºÙ¡G(" & Jm & ")" & VV
    UCunt = 0
    On Error Resume Next
       UCunt = UFD.Count '¹J¨ì¡eSystem Volume Information¡f·|¿ù»~
    On Error GoTo 999
    If UCunt = 0 Then GoTo 101
    For Each GG In UFD
        Km = Km + 1: xD2(Km) = GG.Path
    Next
101: Next
CCunt = CCunt + 1
If Val([C4]) > 0 Then If CCunt >= [C4] Then Km = 0
If Km > 0 Then Urr = xD2.items: xD2.RemoveAll: Km = 0: GoTo RE_GET
'---------------------------------------
If Jm > Rows.Count - 1 Then MsgBox "¸ê®Æ§¨¼Æ¶q¶W¹L¤u§@ªí¥i®e¯Ç¦C¼Æ¡I": GoTo 999
Application.StatusBar = "¡½¡½¡½¸ü¤J¤Î¾ã²z¸ê®Æ¤¤¡D¡D¡D¡D¡D"
ReDim Arr(Jm - 1, 3)
For Each UU In xD1.items
    Arr(k, 0) = UU(0): Arr(k, 1) = UU(1)
    Arr(k, 2) = UU(2): Arr(k, 3) = UU(3): k = k + 1
Next
With [Uhead].Cells(2, 1).Resize(Jm, 5)
     .Rows(1).Copy .Cells
     .Item(2).Resize(Jm, 4) = Arr
     .Sort Key1:=.Item(5), Order1:=xlAscending, Header:=xlNo
     .Columns(1).FormulaR1C1 = "=IF(RC[3]="""","""",HYPERLINK(RC[4],""¡½""))"
End With
[D1] = "=D7"
999: [E4] = "": Application.StatusBar = False
End Sub

millerch

¦^´_ 5# Andy2483

ÁÂÁ¸ԲӸê®Æ
§Ú¦n¦n¬ã¨s¤@¤U

samwang

¦^´_ 3# millerch

½Ð´ú¸Õ¬Ý¬Ý¡AÁÂÁÂ
Sub test()
Dim a, fs, f, fc, f1
Set fs = CreateObject("Scripting.FileSystemObject")
Range("c4").Select
With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = "D:\"
    .Title = "======= ¿ï¾Ü¸ê®Æ§¨ ========"
    .Show
    On Error GoTo EndSub:
    a = .SelectedItems(1)
End With
Set f = fs.GetFolder(a)
Set fc = f.Files
For Each f1 In fc
    With ActiveCell
        .Value = f1.Path
        .Offset(0, 1).Value = f1.Name
        .Offset(0, 2).Value = f1.Size
        .Offset(0, 3).Value = f1.Type
        .Offset(0, 4).Value = f1.DateCreated
        .Offset(0, 5).Value = f1.DateLastAccessed
        .Offset(1, 0).Select
    End With
Next
Set fs = Nothing
Set f = Nothing
Set fc = Nothing
EndSub:
End Sub

millerch

¦^´_ 7# samwang


   ·PÁ¤j¤j

Emily

¦^´_ 1# millerch
­É¥Î samwang ¿ï¨ú dir ³¡¥÷
¦C¥X§A·Q­nªº xlsm ÀÉ

1. Private fso As Object
   
2. 
   
3. Public Sub ListAllXlsmFiles()
   
4. Dim foundFiles As New Collection
   
5. Dim foundFile As Variant
   
6. Dim DirPath As String
   
7. 
   
8. Set fso = CreateObject("Scripting.FileSystemObject")
   
9. Range("A1").Select
   
10. With Application.FileDialog(msoFileDialogFolderPicker)
    
11.     .InitialFileName = "G:\"
    
12.     .Title = "======= ¿ï¾Ü¸ê®Æ§¨ ========"
    
13.     .Show
    
14.     On Error GoTo EndSub
    
15.     DirPath = .SelectedItems(1)
    
16. End With
    
17. 
    
18. FindAllFiles DirPath, "xlsm", foundFiles
    
19. 
    
20. For Each foundFile In foundFiles
    
21.     With ActiveCell
    
22.         .Value = foundFile
    
23.         .Offset(1, 0).Select
    
24.     End With
    
25. Next foundFile
    
26. EndSub:
    
27. End Sub
    
28. 
    
29. Private Sub FindAllFiles(parentFolder As String, extension As String, foundFiles As Collection)
    
30. Dim thisFolder As Object
    
31. Dim subFolder As Object
    
32. Dim thisFile As Object
    
33. Dim testObject As Object
    
34. 
    
35. On Error Resume Next
    
36. Set thisFolder = fso.GetFolder(parentFolder)
    
37. 
    
38. Err.Clear
    
39. Set testObject = thisFolder.Files
    
40. If Err.Number = 0 Then
    
41.     For Each thisFile In thisFolder.Files
    
42.         If LCase(thisFile.Name) Like "*." & LCase(extension) Then
    
43.             foundFiles.Add thisFile.Path
    
44.         End If
    
45.     Next thisFile
    
46. End If
    
47. 
    
48. Err.Clear
    
49. Set testObject = thisFolder.SubFolders
    
50. If Err.Number = 0 Then
    
51.     For Each subFolder In thisFolder.SubFolders
    
52.         FindAllFiles subFolder.Path, extension, foundFiles
    
53.     Next subFolder
    
54. End If
    
55. End Sub

½Æ»s¥N½X

HTGeorge

§Ú¬O³o¼Ë¥Îªº
Dim TPP(300, 2) As String
            Dim myFolder1 As String, myFile1 As String
                       myFolder1 = "D:\¬d¸ß¥Î¸ê®Æ®w\"
                       myFile1 = Dir(myFolder1)  ¡¥«ü©w¥Ø¿ý
                J = 0
                Do While myFile1 <> ""
                    If myFile1 Like "*.xlsm" Or myFile2 Like "*.XLSM" Then
                        TPP(M, 0) = "ª©"
                        TPP(M, 1) = myFile1
                        TPP(M, 2) = " D:\¬d¸ß¥Î¸ê®Æ®w\" & myFile1
                        M = M + 1
                    End If
                    myFile1 = Dir()
                    J = J + 1
                Loop
            List_item.List() = TPP  ¡¥List_item ¬°¦Cªíª«¥ó