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

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