[µo°Ý] ¦p¦ó¤ñ¹ï¥XA/BÄæ­«½Æ¤Î¤í¯Ê¤§¼Æ­È

loyyee

¼Æ­È¤ñ¹ï.rar (9.97 KB)

¤U¸ü¦¸¼Æ: 16

2011-10-8 01:12

½Ð°Ý¦p¦ó¤ñ¹ï¥XA/BÄæ­«½Æ¤Î¤í¯Ê¤§¼Æ­È?

AÄæ            BÄæ
A0001        A0001
A0002        A0002
A0003        A0003
A0003        A0004
A0005        A0004
A0007        A0006

AÄæ­«½Æ¼Æ­È:A0003
AÄæ¤í¯Ê¼Æ­È:A0004.A0006
BÄæ­«½Æ¼Æ­È:A0004
BÄæ¤í¯Ê¼Æ­È:A0005.A0007

Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð

°õ¦æ«e:

¤U¸ü (126.73 KB)

2023-6-15 15:10

°õ¦æµ²ªG:

¤U¸ü (136.08 KB)

2023-6-15 15:11

Option Explicit
Sub TEST()
Dim Brr, Va&, Vb&, Z, Q, i&, Ra&, Rb&, M&, Ta$, Tb$
[E7:F65536,I2:J65536].ClearContents
Set Z = CreateObject("Scripting.Dictionary")
Brr = Intersect([A1].CurrentRegion, [A:B])
For i = 1 To UBound(Brr)
   Ta = Brr(i, 1): Tb = Brr(i, 2): Brr(i, 1) = "": Brr(i, 2) = ""
   If Ta = "" Then GoTo i01 Else Va = Z(Ta)
   If Va = 1 Then
      Ra = Ra + 1
      Brr(Ra, 1) = Ta
      M = IIf(M < Ra, Ra, M)
      Else:
         Z(Ta) = 1
   End If
i01: If Tb = "" Then GoTo i02 Else Vb = Z("|" & Tb)
   If Vb = 1 Then
      Rb = Rb + 1
      Brr(Rb, 2) = Tb
      M = IIf(M < Rb, Rb, M)
      Else
         Z("|" & Tb) = 1
   End If
i02: Next
If M > 0 Then [E7].Resize(M, 2) = Brr
ReDim Brr(1 To UBound(Brr), 1 To 2)
Ra = 0: Rb = 0: M = 0
For Each Q In Z.KEYS
   If InStr(Q, "|") = 0 Then
      If Z.Exists("|" & Q) = Empty Then
         Rb = Rb + 1
         Brr(Rb, 2) = Q
      End If
      ElseIf Z.Exists(Mid(Q, 2)) = Empty Then
         Ra = Ra + 1
         Brr(Ra, 1) = Mid(Q, 2)
   End If
   If M < Ra Then M = Ra
   If M < Rb Then M = Rb
Next
If M > 0 Then [I2].Resize(M, 2) = Brr
Set Z = Nothing: Erase Brr
End Sub

loyyee

¦^´_ 12# Hsieh

If s > 0 Then Cells(2, 9 + i).Resize(s, 1) = Application.Transpose(Ay): s = 0: Erase Ay ­n§ï¦¨
If s > 0 Then Cells(2, 10 - i).Resize(s, 1) = Application.Transpose(Ay): s = 0: Erase Ay
   
¤í¯Ê¼Æ­ÈÄæ¦ì¤~·|¹ïÀ³¨ì¡C

fyo00241

·PÁ¦U¤j¤jªº¤À¨É,,ÁöµM¤£¯à¤U¸üªþ¥ó¤]¾Ç²ß¤F

loyyee

¦^´_ 12# Hsieh

¥i¥H¥Î¤F¡AHsieh·PÁ±z«üÂI!

Hsieh

¦^´_ 11# loyyee
¨Ã«D¸ê®Æµ§¼Æ°ÝÃD
¬O¦pªG¨S¦³©M±ø¥óªº¸ê®Æ´N·|³y¦¨Resize¥X¿ù

1. Sub Ex()
   
2. Dim Ay(), Ay1()
   
3. Set d = CreateObject("Scripting.dictionary")
   
4. Set d1 = CreateObject("Scripting.dictionary")
   
5. [E6].CurrentRegion.Offset(1, 0) = ""
   
6. [I1].CurrentRegion.Offset(1, 0) = ""
   
7. 
   
8. ar1 = [A1].CurrentRegion.Columns(1).Value
   
9. ar2 = [A1].CurrentRegion.Columns(2).Value
   
10. ar = Array(ar1, ar2)
    
11. For i = 0 To 1
    
12. For Each a In ar(i)
    
13.    Select Case i
    
14.    Case 0
    
15.    If a <> "" Then d(a) = d(a) + 1
    
16.    Case 1
    
17.    If a <> "" Then d1(a) = d1(a) + 1
    
18.    End Select
    
19. Next
    
20. Next
    
21. dic = Array(d, d1)
    
22. For i = 0 To 1
    
23. For Each ky In dic(i).keys
    
24. p = IIf(i = 0, 1, 0)
    
25.    If dic(p).exists(ky) = False Then
    
26.    ReDim Preserve Ay(s)
    
27.    Ay(s) = ky
    
28.    s = s + 1
    
29.    End If
    
30.    If dic(i)(ky) > 1 Then
    
31.    ReDim Preserve Ay1(k)
    
32.    Ay1(k) = ky
    
33.    k = k + 1
    
34.    End If
    
35. Next
    
36. If s > 0 Then Cells(2, 9 + i).Resize(s, 1) = Application.Transpose(Ay): s = 0: Erase Ay
    
37. If k > 0 Then Cells(7, 5 + i).Resize(k, 1) = Application.Transpose(Ay1): k = 0: Erase Ay1
    
38. Next
    
39. End Sub

½Æ»s¥N½X

loyyee

¦^´_ 10# dechiuan999

±z¦n µ{¦¡¥i¥H¥Î¤F!
¦ý¦pªG¸ê®Æ§ïÅܦpªþÀÉ¥B¤W¤dµ§·|¥X²{¿ù»~¡A³Ò¾r±zÀ°¦£¬Ý¬Ý¡C

¼Æ­È¤ñ¹ï2.rar (65.37 KB)

¤U¸ü¦¸¼Æ: 16

2011-10-9 16:02

dechiuan999

§A¦n¡G

   ½Ð¦A¸Õ¸Õ¦p¤U¡G
Sub aa()
   
    Dim mSht As Worksheet
    Dim mRng1 As Range, mRng2 As Range, E As Range
    Dim mDic1 As Object
    Dim mDic2 As Object
    Dim mData1(), mData2()
    Dim s%, s1%, s2%
   
    Set mDic1 = CreateObject("scripting.dictionary")
    Set mDic2 = CreateObject("scripting.dictionary")        
    Set mSht = Worksheets(1)
    With mSht
        Set mRng1 = .Range("a1", .Range("a" & .Rows.Count).End(xlUp))
        Set mRng2 = .Range("b1", .Range("b" & .Rows.Count).End(xlUp))
      
        For Each E In mRng1
            If E.Value <> "" Then
                mDic1(E.Value) = mDic1(E.Value) + 1
            End If
        Next
      
        
        For Each key1 In mDic1.Keys
            If mDic1(key1) > 1 Then
                ReDim Preserve mData1(s1)
                mData1(s1) = key1
                s1 = s1 + 1
            End If
        Next
               
        For Each E In mRng2
            If E.Value <> "" Then
                mDic2(E.Value) = mDic2(E.Value) + 1
            End If
        Next
        
        For Each key2 In mDic2.Keys
            If mDic2(key2) > 1 Then
                ReDim Preserve mData2(s2)
                mData2(s2) = key2
                s2 = s2 + 1
            End If
        Next
        
               
        .Range("e6") = "­«½Æ¼Æ­È"
        .Range("e6:f6").Merge
        .Range("e7").Resize(s1) = Application.Transpose(mData1)
        .Range("f7").Resize(s2) = Application.Transpose(mData2)
      
        
        Erase mData1
        Erase mData2
        s1 = 0
        s2 = 0
        
        For Each key1 In mDic1.Keys
            If Not mDic2.Exists(key1) Then
                ReDim Preserve mData1(s1)
                mData1(s1) = key1
                s1 = s1 + 1
            End If
        Next
        
        For Each key2 In mDic2.Keys
            If Not mDic1.Exists(key2) Then
                ReDim Preserve mData2(s2)
                mData2(s2) = key2
                s2 = s2 + 1
            End If
        Next
        
        .Range("i1") = "AÄæ¯Ê¤§¼Æ­È"
        .Range("j1") = "BÄæ¯Ê¤§¼Æ­È"
        
        .Range("i2").Resize(s1) = Application.Transpose(mData1)
        .Range("j2").Resize(s2) = Application.Transpose(mData2)
            
    End With
   
    Set mDic1 = Nothing
    Set mDic2 = Nothing
    Set mRng1 = Nothing
    Set mRng2 = Nothing
   
End Sub

loyyee

¦^´_ 8# dechiuan999

·PÁ±z¼ö¤ß«ü¾É¥¨¶°¥i¥H¥Î¡A¦ý¬O¦³¤@¨Ç°ÝÃD:
1.¹J¨ì¼Æ­È¤¤¶¡¦³³sÄòªÅ¥Õ®É¡AªÅ¥Õ¤]·|³Q§ì¨ì"­«½Æ¼Æ­È"¡C
2.³sÄò­«½Æ¼Æ­È·|³£³Q§ì¥X¡A©êºp³oÂI§Ú·íªì¨S»¡²M·¡­«½Æ¼Æ­È§Ú¥u­n§ì¤@¦¸´N¦n¡C

¼Æ­È¤ñ¹ï-Ans2.rar (27.57 KB)

¤U¸ü¦¸¼Æ: 7

2011-10-8 16:33

dechiuan999

§A¦n¡G
   
     §Aªº´£°ÝÅý§Ú¤]¦³¾Ç²ßªº¾÷·|¡C
ÁÂÁ§A¡I
½Ð¸Õ¸Õ¤U¦C¬O§_¥i¾A¥Î¡C
Sub aa()
   
    Dim mSht As Worksheet
    Dim mRng1 As Range, mRng2 As Range, E As Range   
    Dim mDic1 As Object
    Dim mDic2 As Object   
    Dim mData1(), mData2()
    Dim s1%, s2%
    Dim key1, key2
   
    Set mDic1 = CreateObject("scripting.dictionary")
    Set mDic2 = CreateObject("scripting.dictionary")
   
    Set mSht = Worksheets(1)
    With mSht
        Set mRng1 = .Range("a1", .Range("a" & .Rows.Count).End(xlUp))
        Set mRng2 = .Range("b1", .Range("b" & .Rows.Count).End(xlUp))
      
        For Each E In mRng1
            If Not mDic1.Exists(E.Value) Then
                mDic1.Add (E.Value), E.Value
            Else
                ReDim Preserve mData1(s1)
                mData1(s1) = E.Value
                s1 = s1 + 1
            End If
        Next        
               
        For Each E In mRng2
            If Not mDic2.Exists(E.Value) Then
                mDic2.Add (E.Value), E.Value
            Else
                ReDim Preserve mData2(s2)
                mData2(s2) = E.Value
                s2 = s2 + 1
            End If
        Next
        .Range("e6") = "­«½Æ¼Æ­È"
        .Range("e6:f6").Merge
        .Range("e7").Resize(s1) = Application.Transpose(mData1)
        .Range("f7").Resize(s2) = Application.Transpose(mData2)
        'mKey2 = mDic2.Keys
        'mItem2 = mDic2.Items
        
        Erase mData1
        Erase mData2
        s1 = 0
        s2 = 0
        
        For Each key1 In mDic1.Keys
            If key1 <> mDic2(key1) Then
                ReDim Preserve mData1(s1)
                mData1(s1) = key1
                s1 = s1 + 1
            End If
        Next
        
        For Each key2 In mDic2.Keys
            If key2 <> mDic1(key2) Then
                ReDim Preserve mData2(s2)
                mData2(s2) = key2
                s2 = s2 + 1
            End If
        Next
        
        .Range("i1") = "AÄæ¯Ê¤§¼Æ­È"
        .Range("j1") = "BÄæ¯Ê¤§¼Æ­È"
        
        .Range("i2").Resize(s1) = Application.Transpose(mData1)
        .Range("j2").Resize(s2) = Application.Transpose(mData2)        
            
    End With
   
    Set mDic1 = Nothing
    Set mDic2 = Nothing
    Set mRng1 = Nothing
    Set mRng2 = Nothing   
   
End Sub