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

¤j¶q¸ê®Æ¤ñ¹ï­pºâ¤Î±Æ¦W

¦^´_ 1# oak0723-1

¹Ï1»P¹Ï2³£¬O¤@¼Ë

TOP

¦^´_ 3# oak0723-1 [/b


§Aªº¹Ï2»PªþÀɦ³ÂI¤£¤@¼Ë¡A¥BªþÀɪº¤½¦¡¤]¶]±¼¤F¡A
¹ï¤£°_«Ü»{¯uªº¦b¬Ý¤F¡A¦ýÁÙ¬O¬Ý¤£»Ý¨D¡A ¥i¥H¥t¥~´y±Ô¤@¤U¡A·PÁÂ

TOP

¦^´_ 5# oak0723-1

¦]¬°§Aªº´y­z¤¤²Ä1ÂI~7ÂI¦³¥]§t»¡©ú©M»Ý¨D¡A©Ò¥H¤£½T©w¦p¤U¬O§_¬°±zªº»Ý¨D¡A¦p¹Ï¤ù¬õ®Ø¬O¦³³B²zªºµ²ªG¡A½Ð´ú¸Õ¬Ý¬Ý¡AÁÂÁ¡C

Sub test()
Dim Ar_in, Arr, Arr1, Brr(), Crr(), xD, T, T1, n&, i&, j&, R&
Set xD = CreateObject("Scripting.Dictionary")
Ar_in = Sheets("¿é¤J").Range("i3:in3")
For sh = 2 To Sheets.Count
    With Sheets(sh)
        .Range("i3").Resize(1, UBound(Ar_in, 2)) = Ar_in
        R = .[b65536].End(3).Row: If R < 2 Then GoTo 95
        Arr1 = .Range(.[b5], .[b65536].End(3)): Arr = .Range("i3:in" & UBound(Arr1) + 4)
        ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr, 2))       'IT3:RY
        ReDim Preserve Crr(1 To UBound(Arr) - 1, 1 To sh - 1)  '¿é¤Jªº²Î­p
        Crr(1, sh - 1) = .Name
        For x = 1 To UBound(Arr1)
            If Arr1(x, 1) = "" Then GoTo 95
            For i = 3 To UBound(Arr)
                For j = 1 To UBound(Arr, 2)
                    T = Arr(i, j): T1 = Arr(1, j)
                    If T1 = "" Then GoTo 90
                    If T1 = T Then
                        Brr(i - 2, j) = 1: n = n + 1
                    Else
                        Brr(i - 2, j) = 0
                    End If
90:             Next j
            Crr(i - 1, sh - 1) = n: n = 0
            Next i
95:     Next x
        .[it5].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
    End With
Next
n = 0
With Sheets(1)
    .[i4:r4].NumberFormatLocal = "@"
    .[i4].Resize(UBound(Crr), UBound(Crr, 2)) = Crr
    With [s5].Resize(UBound(Crr) - 1)
            .Formula = "=Sum(i5:r5)": .Value = .Value
    End With
    With Range([s5], [s4].End(4))
        Arr = .Value
        .Sort Key1:=.Item(1), Order1:=2, Header:=2
        Brr = .Value: .Value = Arr
    End With
    For i = 1 To UBound(Brr)
        T = Brr(i, 1): If Not xD.Exists(T) Then n = n + 1: xD(T) = n
    Next
    For i = 1 To UBound(Arr): Arr(i, 1) = xD(Arr(i, 1)): Next
    .[t5].Resize(UBound(Arr)) = Arr
End With
End Sub
1.JPG

TOP

¦^´_ 7# oak0723-1

¤w§ó·s¦p¤U¡A½Ð¦A´ú¸Õ¬Ý¬Ý¡AÁÂÁÂ
¥t¥~"¿é¤J"¤u§@ªí­n©ñ¦b²Ä1­Ó

Sub test()
Dim Ar_in, Arr, Arr1, Brr(), Crr(), xD, T, T1, n&, i&, j&, R&, sh%, MaxR&
Set xD = CreateObject("Scripting.Dictionary")
Ar_in = Sheets("¿é¤J").Range("i3:in3")
For sh = 2 To Sheets.Count
    With Sheets(sh)
        .Range("i3").Resize(1, UBound(Ar_in, 2)) = Ar_in
        R = .[b65536].End(3).Row: If R < 2 Then GoTo 95
        Arr1 = .Range(.[b5], .[b65536].End(3)): Arr = .Range("i3:in" & UBound(Arr1) + 4)
        ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr, 2)) 'IT3:RY
        ReDim Preserve Crr(1 To 100000, 1 To sh - 1)     '¿é¤Jªº²Î­p
        If MaxR < UBound(Arr) Then MaxR = UBound(Arr)
        Crr(1, sh - 1) = .Name
        For x = 1 To UBound(Arr1)
            If Arr1(x, 1) = "" Then GoTo 95
            For i = 3 To UBound(Arr)
                For j = 1 To UBound(Arr, 2)
                    T = Arr(i, j): T1 = Arr(1, j)
                    If T1 = "" Then GoTo 90
                    If T1 = T Then
                        Brr(i - 2, j) = 1: n = n + 1
                    Else
                        Brr(i - 2, j) = 0
                    End If
90:             Next j
            Crr(i - 1, sh - 1) = n: n = 0
            Next i
95:     Next x
        .[it5].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
    End With
Next
n = 0
With Sheets(1)
    .[i4:r4].NumberFormatLocal = "@"
    .[i4].Resize(MaxR, UBound(Crr, 2)) = Crr
    With .[s5].Resize(MaxR - 2)
            .Formula = "=Sum(i5:r5)": .Value = .Value
    End With
    With Range([s5], [s4].End(4))
        Arr = .Value
        .Sort Key1:=.Item(1), Order1:=2, Header:=2
        Brr = .Value: .Value = Arr
    End With
    For i = 1 To UBound(Brr)
        T = Brr(i, 1): If Not xD.Exists(T) Then n = n + 1: xD(T) = n
    Next
    For i = 1 To UBound(Arr): Arr(i, 1) = xD(Arr(i, 1)): Next
    .[t5].Resize(UBound(Arr)) = Arr
End With
End Sub
1.JPG

TOP

¦^´_  samwang


    §Ú±N¤u§@ªí09ªº!5~IN1048528°Ï°ì¸ê®Æ¥þ³¡§R°£°õ¦æµ{¦¡«á¦A¿é¤JA1¸ê®Æ
µ²ªG´N¥d¦í ...
oak0723-1 µoªí©ó 2022-5-16 19:49


¤w§ó·s¦pªþ¥ó¡A½Ð´ú¸Õ¬Ý¬Ý¡AÁÂÁÂ

(1110516-1)¤ñ¹ïtest_0516.zip (199.4 KB)

TOP

¥»©«³Ì«á¥Ñ samwang ©ó 2022-5-17 11:15 ½s¿è
¦^´_  samwang


    ¥ý¶i§A¦n
§Ú±N¤u§@ªí01ªºI5:I1005¶ñ¤J¸ê®Æ1¸U¦C¸ê®Æ,°õ¦æ¨S¦h¤[´NÅã¥Ü"¨S¦^À³",§Ú ...
oak0723-1 µoªí©ó 2022-5-17 09:12


¤w§ó·s¡A4¸U¦hµ§¬ù12¬í¡AÀɮפӤj66M¤£¤W¶Ç¡A½Ð¦Û¦æ«Ø¸ê®Æ«á¦A´ú¸Õ¬Ý¬Ý¡AÁÂÁÂ
¥t¥~¡A¥Î§Aªº#11ªþ¥óÀÉ®×¥h°õ¦æ·|¶]«Ü¤[(·í±¼)¡A­««Ø¸ê®Æ¼Æ¾Ú¡A«Øij¼Æ­ÈÂର­È¤£­n®Ø½uµM«á¦A°õ¦æµ{¦¡(¦p¹Ï¤ù)

Sub test()
Dim Ar_in, Arr, Arr1, Brr(), Crr(), xD, T, T1, n&, i&, j&, R&, sh%, MaxR&
Set xD = CreateObject("Scripting.Dictionary")
Tm = Timer
Ar_in = Sheets("¿é¤J").Range("i3:in3")
For sh = 2 To Sheets.Count
    With Sheets(sh)
        .Range("i3").Resize(1, UBound(Ar_in, 2)) = Ar_in
        R = .[b65536].End(3).Row: If R < 2 Then GoTo 95
        Arr1 = .Range("b4:b" & R): Arr = .Range("i3:in" & R)
        ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr, 2)) 'IT3:RY
        ReDim Preserve Crr(1 To 100000, 1 To sh - 1)     '¿é¤Jªº²Î­p
        If MaxR < UBound(Arr) Then MaxR = UBound(Arr)
        Crr(1, sh - 1) = .Name
        For i = 3 To UBound(Arr)
            For j = 1 To UBound(Arr, 2)
                T = Arr(i, j): T1 = Arr(1, j)
                If T1 = "" Then GoTo 90
                If T1 = T Then
                    Brr(i - 2, j) = 1: n = n + 1
                Else
                    Brr(i - 2, j) = 0
                End If
90:         Next j
            Crr(i - 1, sh - 1) = n: n = 0
95:    Next i
        .[it5].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
    End With
Next
n = 0
With Sheets(1)
    .[i4:r4].NumberFormatLocal = "@"
    .[i4].Resize(MaxR, UBound(Crr, 2)) = Crr
    With .[s5].Resize(MaxR - 2)
            .Formula = "=Sum(i5:r5)": .Value = .Value
    End With
    With Range([s5], [s4].End(4))
        Arr = .Value
        .Sort Key1:=.Item(1), Order1:=2, Header:=2
        Brr = .Value: .Value = Arr
    End With
    For i = 1 To UBound(Brr)
        T = Brr(i, 1): If Not xD.Exists(T) Then n = n + 1: xD(T) = n
    Next
    For i = 1 To UBound(Arr): Arr(i, 1) = xD(Arr(i, 1)): Next
    .[t5].Resize(UBound(Arr)) = Arr
End With
MsgBox Timer - Tm
End Sub
1.JPG
2022-5-17 11:02

TOP

¦^´_  samwang

©êºp,º|¤F1­Ó°ÝÃD
1.¿é¤JÄæ¦ì­Y¬OªÅ¥Õ,´N¤£¤ñ¹ï,©Ò±oªº­È´N¬O0(¦p¹Ï)
2.¿é¤JÄæ¦ì­Y¬O ...
oak0723-1 µoªí©ó 2022-5-21 16:57


¬O³o¼Ë¶Ü?­×§ï¦p¤U¬õ®Ø¡A ½Ð½T»{¡AÁÂÁÂ
                If T1 = "" Then
                    Brr(i - 2, j) = 0
                ElseIf T1 = "0" Then
                    Brr(i - 2, j) = ""
                ElseIf T1 = T Then
                    Brr(i - 2, j) = 1: n = n + 1
                ElseIf T1 <> T Then
                    Brr(i - 2, j) = 0
                End If
1.JPG

TOP

        ÀR«ä¦Û¦b : ­ì½Ì§O¤H´N¬Oµ½«Ý¦Û¤v¡C
ªð¦^¦Cªí ¤W¤@¥DÃD