ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

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

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

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

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

¦^´_ 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
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

¦^´_ 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

TOP

¦^´_ 3# millerch


    ÁÂÁ«e½ú¦^´_

Application.GetOpenFilename ¤èªk (Excel)


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
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

¦^´_ 3# millerch


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

°õ¦æ«e:


°õ¦æµ²ªG:


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
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

¦^´_ 5# Andy2483

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

TOP

¦^´_ 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

TOP

¦^´_ 7# samwang


   ·PÁ¤j¤j

TOP

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

  2. Public Sub ListAllXlsmFiles()
  3. Dim foundFiles As New Collection
  4. Dim foundFile As Variant
  5. Dim DirPath As String

  6. Set fso = CreateObject("Scripting.FileSystemObject")
  7. Range("A1").Select
  8. With Application.FileDialog(msoFileDialogFolderPicker)
  9.     .InitialFileName = "G:\"
  10.     .Title = "======= ¿ï¾Ü¸ê®Æ§¨ ========"
  11.     .Show
  12.     On Error GoTo EndSub
  13.     DirPath = .SelectedItems(1)
  14. End With

  15. FindAllFiles DirPath, "xlsm", foundFiles

  16. For Each foundFile In foundFiles
  17.     With ActiveCell
  18.         .Value = foundFile
  19.         .Offset(1, 0).Select
  20.     End With
  21. Next foundFile
  22. EndSub:
  23. End Sub

  24. Private Sub FindAllFiles(parentFolder As String, extension As String, foundFiles As Collection)
  25. Dim thisFolder As Object
  26. Dim subFolder As Object
  27. Dim thisFile As Object
  28. Dim testObject As Object

  29. On Error Resume Next
  30. Set thisFolder = fso.GetFolder(parentFolder)

  31. Err.Clear
  32. Set testObject = thisFolder.Files
  33. If Err.Number = 0 Then
  34.     For Each thisFile In thisFolder.Files
  35.         If LCase(thisFile.Name) Like "*." & LCase(extension) Then
  36.             foundFiles.Add thisFile.Path
  37.         End If
  38.     Next thisFile
  39. End If

  40. Err.Clear
  41. Set testObject = thisFolder.SubFolders
  42. If Err.Number = 0 Then
  43.     For Each subFolder In thisFolder.SubFolders
  44.         FindAllFiles subFolder.Path, extension, foundFiles
  45.     Next subFolder
  46. End If
  47. End Sub
½Æ»s¥N½X

TOP

§Ú¬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ªíª«¥ó

TOP

        ÀR«ä¦Û¦b : ¨ü¤HÂI¤ô¤§®¦¡A¶··í´é¬u¥H³ø¡C
ªð¦^¦Cªí ¤W¤@¥DÃD