[µo°Ý] ¤ñ¹ï¿é¤Jªº¸ê®Æ¡A¨Ã¿z¿ï¦Ü¦U¹ïÀ³¸ê®Æ¦æ

jackson7015

½Ð°Ý§Ú­n¿z¿ï¥X¦U¹ïÀ³¸ê®Æ«á¤À§O¶ñ¤J¥N¸¹
Áä¤J»Ý­n¬d¸ßªº¦r½X«á¡A¦A¤ñ¹ï[C/D/E¦æ]¤ÀÃþ¡A¨Ã¦C¥X¨ä²Å¦Xªº¦r½X
1.¤ñ¹ï[A¦æ]¨Ã¦b[G¦æ]¦C¥X¬Û²Å[C¦æ]ªº¦r½X¡A¦ý±Æ°£[E¦æ]ªº¦r½X
2.¤ñ¹ï[A¦æ]¨Ã¦b[D¦æ]¦C¥X¬Û²Å[I¦æ]ªº¦r½X
3.[A¦æ]¤ñ¹ï[C/D/E¦æ]ªº¦r½X¡A¦b[G¦æ]¦C¥X¤£¬Û²Åªº¦r½X

¤U¸ü (46.75 KB)

2021-9-9 15:00

¥H¤W¤TºØ¤ñ¹ï¦³ÂIÂø¡A¦³ÂI·Q¤£³q
¦A½Ð¯¸¤Wªº«e½ú­Ì¥i¥HÀ°¦£¬Ý¬Ý
·PÁÂ~
¤ñ¹ï¥Î.rar (36.37 KB)

¤U¸ü¦¸¼Æ: 9

2021-9-9 15:06

samwang

¦^´_ 1# jackson7015

½Ð´ú¸Õ¬Ý¬Ý¡AÁÂÁÂ

Sub test()
Dim Arr, Brr(), xD, xD1, T$, AR%, BR%, DR%
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
R = Columns("C:E").Find("*", SearchDirection:=xlPrevious).Row
Arr = Range("C1:E" & R)
For j = 1 To 3: For i = 2 To UBound(Arr)
T = Arr(i, j): xD(T & "_" & j) = 1: xD1(T) = 1
Next i: Next j
Arr = Range([a1], [a65536].End(3))
ReDim Brr(1 To UBound(Arr), 1 To 3)
For i = 2 To UBound(Arr)
    T = Arr(i, 1): N = xD1(T)
    If N <> 1 Then DR = DR + 1: Brr(DR, 1) = T: GoTo 99
    For j = 1 To 2
        If xD.Exists(T & "_" & j) Then
            If j = 1 Then
                If Not xD.Exists(T & "_3") Then
                    AR = AR + 1: Brr(AR, 2) = T
                End If
            Else
                BR = BR + 1: Brr(BR, 3) = T
            End If
        End If
    Next
99: Next
Range("g2").Resize(UBound(Brr), 3) = Brr
End Sub

­ã´£³¡ªL

Sub TEST_A1()
Dim Arr, Brr, xD, T$, i&, j%, N&(4)
Set xD = CreateObject("Scripting.Dictionary")
For j = 1 To 3
    Arr = Range(Cells(1, j + 2), Cells(Rows.Count, j + 2).End(xlUp))
    For i = 2 To UBound(Arr)
        If Arr(i, 1) <> "" Then xD(Arr(i, 1) & "") = j
    Next i
Next j
'----------------------------------
Arr = Range([a1], Cells(Rows.Count, 1).End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To 4)
For i = 2 To UBound(Arr)
    T = Arr(i, 1): If T = "" Then GoTo i01
    j = xD(T) + 1: N(j) = N(j) + 1
    Brr(N(j), j) = T
i01: Next i
[g2].Resize(UBound(Brr), 3) = Brr
End Sub

Andy2483

¦^´_ 1# jackson7015


    ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨Ò
ÁÂÁ¨â¦ì«e½ú«ü¾É
«á¾ÇÂǦ¹©«½m²ß¦r¨å»P°}¦C

Option Explicit
Sub TEST_20230106_1()
Dim Brr, i&, x, Y, j&, Lac&
Set Y = CreateObject("Scripting.Dictionary")
Lac = Cells.SpecialCells(xlLastCell).Row
Brr = Range([A2], Cells(Lac, "E"))
For j = 1 To 5
   If j = 2 Then GoTo Spa
   Set Y(j) = CreateObject("Scripting.Dictionary")
   For i = 1 To UBound(Brr)
      If Brr(i, j) = "" Then GoTo Spa
      Y(j)(Brr(i, j)) = i
   Next
Spa:
Next
ReDim Brr(1 To Y(1).Count, 1 To 3)
For Each x In Y(1).KEYS
   If Y(3)(x) & Y(4)(x) & Y(5)(x) = "" Then
      Y("G") = Y("G") + 1
      Brr(Y("G"), 1) = x
      ElseIf Y(3)(x) > 0 And Y(5)(x) = "" Then
         Y("H") = Y("H") + 1
         Brr(Y("H"), 2) = x
      ElseIf Y(4)(x) > 0 Then
         Y("I") = Y("I") + 1
         Brr(Y("I"), 3) = x
   End If
Next
Range([G2], Cells(Lac, "I")).ClearContents
[G2].Resize(UBound(Brr), 3) = Brr
Set Y = Nothing
End Sub