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

[µo°Ý] ·j´M«e3¤j&«e3¤p­È¡C

¦^´_ 7# ziv976688


¤£¦n·N«ä¡A§ó·s10# ³¡¤Àµ{¦¡½X¦p¤U¡AÁÂÁÂ

WB.Close
         For i = 2 To UBound(Arr)           'Á`¦¸¼Æ:³Ì¤j3¼Æ­È
            K21 = K21 + 1: If xD.Count > 2 And xD(Arr(i, 3)) <> 1 Then Exit For
            Ar21(K21, 1) = Arr(i, 1): Ar21(K21, 2) = Arr(i, 3): xD(Arr(i, 3)) = 1
         Next
         xD.RemoveAll
         For i = UBound(Arr) To 2 Step -1   'Á`¦¸¼Æ:³Ì¤p3¼Æ­È
            K22 = K22 + 1: If xD.Count > 2 And xD(Arr(i, 3)) <> 1 Then Exit For
            Ar22(K22, 1) = Arr(i, 1): Ar22(K22, 2) = Arr(i, 3): xD(Arr(i, 3)) = 1
         Next
         xD.RemoveAll
         For i = 2 To UBound(Arr1)          '­¿¼Æ:³Ì¤j3¼Æ­È
            K31 = K31 + 1: If xD.Count > 2 And xD(Arr1(i, 4) & "_31") <> 1 Then Exit For
            Ar31(K31, 1) = Arr1(i, 1): Ar31(K31, 2) = Arr1(i, 4): xD(Arr1(i, 4)) = 1
         Next
         xD.RemoveAll
        For i = UBound(Arr1) To 2 Step -1   '­¿¼Æ:³Ì¤p3¼Æ­È
            K32 = K32 + 1: If xD.Count > 2 And xD(Arr1(i, 4)) <> 1 Then Exit For
            Ar32(K32, 1) = Arr1(i, 1): Ar32(K32, 2) = Arr1(i, 4): xD(Arr1(i, 4)) = 1
         Next
         xD.RemoveAll
         
         With Sheets("Sheet1")
            .Range("a" & R) = fn

TOP

¥»©«³Ì«á¥Ñ ziv976688 ©ó 2021-9-7 16:54 ½s¿è

¦^´_ 11# samwang
¤£¦n·N«ä~¼W²K±z³\¦h³Â·Ð~¨¯­W±z¤F~ÁÂÁ±z

´ú¸Õµ²ªG :
­ì¥ýªºBUG¬O¸Ñ¨M¤F¡A¦ý#11¼Óªº¶Q¸Ñ¤S²£¥Í¨ä¥¦ªºBUG~­¿¼Æªº²Ä3¤j¶]¤£¥X¨Ó¡C
Àµ½Ð½ç¥¿~ÁÂÁ±z
¬°§Q±z¬d¾\~¤w±N©Ò¦³«e3¤j©M«e3¤pªº¼Ð¥Ü¡A°µ¤@­Ó¬d¸ßªí~½Ð¨£¦³"²Î"¦rªº¦U´ÁÀɮפ§³ÆµùÄæ¡C
TEST_0907.rar (511.35 KB)

TOP

¦^´_ 12# ziv976688

½Ð¥H¦¹¬°¥D¡A³£¤£ª¾¹D§ï¤F­þ¸Ì¡A¦]¬°¦³¨Ç¬O§A­ì¥»¶K¿ùªº¦A¥[¤W§Ú­×§ïªº¡A©Ò¥H¯uªº¦³ÂI¶Ã¡A
Á`¤§¥þ³¡¶K¥X¨Ó¦p¤U¡A½Ð¦A´ú¸Õ¬Ý¬Ý¡AÁÂÁ¡C


Private Sub CommandButton1_Click()
Dim xD, Ar21(1 To 10, 1 To 2), Ar22(1 To 10, 1 To 2), Ar31(1 To 10, 1 To 2), Ar32(1 To 10, 1 To 2)
Dim Path As String, A, Ar(1 To 1000, 1 To 2), Ar1(), Arr, Brr(1 To 7), Crr, T, i&, j&
Dim Drr(1 To 3, 1 To 49), Arr1, R%, K21%, K22%, K31%, K32%, R21%, R22%, R31%, R32%, T1
Set xD = CreateObject("Scripting.Dictionary")
   
    Nrange = "1884" ' InputBox("½Ð¿é¤JDATA!ªº¶}¼ú´Á¼Æ", "¿é¤J´Á¼Æ")
    Order = "0" ' InputBox("½Ð¿é¤J¼W¥[ªºÅÞ¿è±ø¥ó±ø¥ó¤§°_¨´§Ç¸¹", "¿é¤J§Ç¸¹(1~99)©Î¤£¼W¥[(«öEnter)")
    Ncount = "1" ' InputBox("½Ð¿é¤JÅçÃÒª©ªº³sÄò¦¸¼Æ", "¿é¤J¦¸¼Æ(1~10)")
   
    Tm = Timer
    [L1] = ""
    [L2] = ""
    [L3] = ""
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Set fs = CreateObject("Scripting.FileSystemObject")
A = ThisWorkbook.Path     '¨C­Ó¸ê®Æ§¨¦WºÙ¸Ë¤JAr
Set f = fs.GetFolder(A)
Set fc = f.SubFolders
For Each f1 In fc
    n = n + 1
    Ar(n, 1) = f1.Path
    Ar(n, 2) = Split(Split(f1.Name, "_")(4), "-")(0)
Next
For i = 1 To UBound(Ar)   'Ar¥Ñ¤j¦Ü¤p±Æ§Ç
For j = i + 1 To UBound(Ar)
    If Ar(i, 2) < Ar(j, 2) Then
        A = Ar(i, 1)
        Ar(i, 1) = Ar(j, 1)
        Ar(j, 1) = A
    End If
Next j
Next i

For i = 1 To n            '¶}±ÒAr¡A§äÀɦW¦³"²Î"¸Ë¤JAr1
    Set f = fs.GetFolder(Ar(i, 1))
    Set fc = f.Files
    For Each f1 In fc
        If InStr(f1.Path, "²Î") Then
            ReDim Preserve Ar1(n1)
            Ar1(n1) = f1.Path
            n1 = n1 + 1
        End If
    Next f1
Next i

fileOrg = ActiveWorkbook.Name
If n1 > 0 Then
R = 33
     ªíÀY = Array("Á`¦¸¼Æ", "³Ì¤j", "¦¸¤j", "¤T¤j", "", "³Ì¤p", "¦¸¤p", "¤T¤p", _
                   "­¿¼Æ", "³Ì¤j", "¦¸¤j", "¤T¤j", "", "³Ì¤p", "¦¸¤p", "¤T¤p")
     For i1 = 0 To n - 1   '¶}±ÒAr1
         Set WB = Workbooks.Open(Ar1(i1))
         fn = Split(Ar1(i1), "_")(5)
         With Sheets(1)
             If .FilterMode Then .ShowAllData
             With .Range(.[B1], .[E65536].End(3))
                 Crr = .Value
                 .Sort Key1:=.Item(3), Order1:=2, Header:=1
                 Arr = .Value    'Á`¦¸¼Æ
                .Sort Key1:=.Item(4), Order1:=2, Header:=1
                 Arr1 = .Value   '­¿¼Æ
                .Value = Crr
             End With
         End With
         WB.Close
         For i = 2 To UBound(Arr)           'Á`¦¸¼Æ:³Ì¤j3¼Æ­È
            K21 = K21 + 1: If xD.Count > 2 And Not xD.Exists(Arr(i, 3) & "") Then Exit For
            Ar21(K21, 1) = Arr(i, 1): Ar21(K21, 2) = Arr(i, 3): xD(Arr(i, 3) & "") = 1
         Next
         xD.RemoveAll
         For i = UBound(Arr) To 2 Step -1   'Á`¦¸¼Æ:³Ì¤p3¼Æ­È
            K22 = K22 + 1: If xD.Count > 2 And Not xD.Exists(Arr(i, 3) & "") Then Exit For
            Ar22(K22, 1) = Arr(i, 1): Ar22(K22, 2) = Arr(i, 3): xD(Arr(i, 3) & "") = 1
         Next
         xD.RemoveAll
         For i = 2 To UBound(Arr1)          '­¿¼Æ:³Ì¤j3¼Æ­È
            K31 = K31 + 1: If xD.Count > 2 And Not xD.Exists(Arr1(i, 4) & "") Then Exit For
            Ar31(K31, 1) = Arr1(i, 1): Ar31(K31, 2) = Arr1(i, 4): xD(Arr1(i, 4) & "") = 1
         Next
         xD.RemoveAll
        For i = UBound(Arr1) To 2 Step -1   '­¿¼Æ:³Ì¤p3¼Æ­È
            K32 = K32 + 1: If xD.Count > 2 And Not xD.Exists(Arr1(i, 4) & "") Then Exit For
            Ar32(K32, 1) = Arr1(i, 1): Ar32(K32, 2) = Arr1(i, 4): xD(Arr1(i, 4) & "") = 1
         Next
         xD.RemoveAll
         
         With Sheets("Sheet1")
            .Range("a" & R) = fn
            .Range("b" & R).Resize(16) = Application.Transpose(ªíÀY)
            For i = 1 To K21 - 1  'Á`¦¸¼Æ:³Ì¤j3¼Æ­È
                T = Ar21(i, 2): If T1 = T Then R21 = R21 Else R21 = R21 + 1
                Drr(R21, Ar21(i, 1)) = "V": T1 = T
            Next
            .Range("c" & R + 1).Resize(3, 49) = Drr
            R = .[b65536].End(3).Row - 10: Erase Drr: T1 = 0
            
            For i = 1 To K22 - 1  'Á`¦¸¼Æ:³Ì¤p3¼Æ­È
                T = Ar22(i, 2): If T1 = T Then R22 = R22 Else R22 = R22 + 1
                Drr(R22, Ar22(i, 1)) = "V": T1 = T
            Next
            .Range("c" & R).Resize(3, 49) = Drr
            R = .[b65536].End(3).Row - 6: Erase Drr: T1 = 0
            
            For i = 1 To K31 - 1  '­¿¼Æ:³Ì¤j3¼Æ­È
                T = Ar31(i, 2): If T1 = T Then R31 = R31 Else R31 = R31 + 1
                Drr(R31, Ar31(i, 1)) = "V": T1 = T
            Next
            .Range("c" & R).Resize(3, 49) = Drr
            R = .[b65536].End(3).Row - 2: Erase Drr: T1 = 0
            
            For i = 1 To K32 - 1  '­¿¼Æ:³Ì¤p3¼Æ­È
                T = Ar32(i, 2): If T1 = T Then R32 = R32 Else R32 = R32 + 1
                Drr(R32, Ar32(i, 1)) = "V": T1 = T  'If R32 < 4 Then:
            Next
            .Range("c" & R).Resize(3, 49) = Drr
            R = .[b65536].End(3).Row + 2: Erase Drr: T1 = 0
            
         End With
         Erase Ar21: Erase Ar22: Erase Ar31: Erase Ar32: xD.RemoveAll
         K21 = 0: K22 = 0: K31 = 0: K32 = 0: R21 = 0: R22 = 0: R31 = 0: R32 = 0
     Next
End If
Set fs = Nothing: Set f = Nothing: Set fc = Nothing '...................................................................
    Set xD = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet1")
        .[A1] = Nrange
        .[A2].Formula = "=Count(A33:A2000) & ""´Á""": .[A2] = .[A2].Value 'AÄ檺´Á­Ó¼Æ
        .[A3] = "¶}¼ú¸¹½X"
        .[A4:A10].Formula = "=IF(A$1="""","""",VLOOKUP(A$1,DATA!$A:$H,ROW()-2,))": .[A4:A10] = .[A4:A10].Value  '=Nrange´Á¼Æªº¶}¼ú¸¹½X
        .[A32] = "´Á¼Æ"

        .[C2:AY16].Formula = "=IF(SUMPRODUCT(SUBTOTAL(3,OFFSET(C34,ROW($1:$1017)*17-17,)))>0,SUMPRODUCT(SUBTOTAL(3,OFFSET(C34,ROW($1:$1017)*17-17,))),"""")": .[C2:AY16] = .[C2:AY16].Value 'C2:AY16ªº¤½¦¡

'ª©­±®æ¦¡.........................................................
            With .Columns("A:AY")
                .Font.Name = "Verdana"  '¦rÅé
                .HorizontalAlignment = xlCenter  '¥ª¥k¸m¤¤
                .VerticalAlignment = xlCenter  '¤W¤U¸m¤¤
                .EntireColumn.AutoFit  '¦Û°ÊÄæ¼e
                .EntireRow.AutoFit  '¦Û°Ê¦C°ª
            End With
End With
'.....................................................................................
        Sheets("Sheet1").Copy
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\7«e3¤j&¤p_" & Order & "_" & Nrange & "´Á_" & Sheets("Sheet1").[A2] & "_" & Ncount & "¦¸" & ".xls"
        ActiveWindow.Close
    Application.Goto [DATA!J1]
[L1] = Nrange & "=" & Format((Timer - Tm) / 24 / 60 / 60, "hh:mm:ss")
[L2] = "¼W¥[ªºÅÞ¿è±ø¥ó§Ç¸¹=" & Order
[L3] = "ÅçÃÒª©ªº³sÄò¦¸¼Æ= " & Ncount

End Sub

TOP

¦^´_ 13# samwang
´ú¸Õ¦¨¥\(§t«e3¤j>=2­Ó¡F«e3¤p>=2­Ó)
¸U¤À·PÁ±z¼ö¤ßªºÀ°¦£©M­@¤ß«ü¾É~·P®¦

TOP

¦^´_ 14# ziv976688


  ¢±¡Ä¢äªºÁ`¼Æ¶q¥Ø«e¬O¢´¢·­Ó¡]¥¿½T¬O¢µ¢¯­Ó¡^¡ã5´Á*2Äæ*(«e3¤j+«e3¤p)>=60~
>> §Ú¤@ª½¤£¸Ñ¡A³o¬O¤°»ò·N«ä? ¦p¦ó§PÂ_?

TOP

¥»©«³Ì«á¥Ñ ziv976688 ©ó 2021-9-7 22:22 ½s¿è

¦^´_ 15# samwang
¦pªG«e3¤j©M«e3¤p³£¬O¦U¥u¦³1­Ó
´Á¼Æ=5´Á
Á`¦¸¼Æ=1
­¿¼Æ=1
«e3¤j=3
«e3¤p=3
©Ò¥H~
5*(1+1)*(3+3)=60
¦A¦¸ÁÂÁ±zªº­@¤ß«ü¾É~¨ü¯q¨}¦h¡C
¨¯­W¤F~·P®¦

TOP

        ÀR«ä¦Û¦b : §g¤l¬°¥Ø¼Ð¡A¤p¤H¬°¥Øªº¡C
ªð¦^¦Cªí ¤W¤@¥DÃD