[µo°Ý] Àx¦s®æªº¦X¨Ö°ÝÃD

pinklee

¤U¸ü (11.65 KB)

2011-7-16 08:52

¦p¹Ï ½Ð°Ý¤£­n¥Î¨ç¼Æ ©Î&,§âABC¤TÄ檺¸ê®Æ¦X¨Ö¶Ñ´À©wÀx¦s®æ¸Ì
A B C ¤£¤@©w·|¦³¸ê®Æ ¦]¬°¦³®É¤£·|¦³­«½Æ
¥ý·PÁ¦U¦ì¥ý¶i

dechiuan999

§A¦n¡G
  
   ½Ð¸Õ¸Õ¦p¤U
Sub aa()
   
    Dim mDic1 As Scripting.Dictionary
    Dim mDic2 As Scripting.Dictionary
    Dim mDic3 As Scripting.Dictionary
    Dim mRng1, mRng2, mRng3
    Dim mSht As Worksheet
    Dim mRow1%, mRow2%, mRow3%
    Dim mStr1$
    Dim s%, s1%
    Dim mData1(), mData2(), mData3()
    Dim mRng As Range
   
    Set mDic1 = CreateObject("scripting.dictionary")
    Set mDic2 = CreateObject("scripting.dictionary")
    Set mDic3 = CreateObject("scripting.dictionary")
   
   
    Set mSht = Worksheets(1)
    With mSht
        mRow1 = .[f65536].End(xlUp).Row
        mRow2 = .[h65536].End(xlUp).Row
        mRow3 = .[j65536].End(xlUp).Row
        mRng1 = .Range("f1:g" & .[f65536].End(xlUp).Row)
        mRng2 = .Range("h1:i" & .[i65536].End(xlUp).Row)
        mRng3 = .Range("j1:k" & .[j65536].End(xlUp).Row)
        
        
        For s = 1 To mRow1
            mStr1 = mRng1(s, 1)
            mDic1.Add mRng1(s, 1), ""
        Next
        
        For s = 1 To UBound(mRng1)
            mStr1 = mRng1(s, 2)
            If mDic1.Exists(mStr1) = True Then
                ReDim Preserve mData1(s1)
                mData1(s1) = mStr1 & ","
                s1 = s1 + 1
            End If
        Next
   
        .Range("a1").Resize(s1) = Application.Transpose(mData1)
        
        Set mRng = .Columns("a")
        With mRng
            .Replace ",", ""
        End With
        
        For s = 1 To mRow2
            mStr1 = mRng2(s, 1)
            mDic2.Add mRng2(s, 1), ""
        Next
        
        s1 = 0
        
        For s = 1 To UBound(mRng2)
            mStr1 = mRng2(s, 2)
            If mDic2.Exists(CInt(mStr1)) = True Then
                ReDim Preserve mData2(s1)
                mData2(s1) = mStr1 & ","
                s1 = s1 + 1
            End If
        Next
        
     
        .Range("b1").Resize(s1) = Application.Transpose(mData2)
        Set mRng = .Columns("b")
        With mRng
            .Replace ",", ""
        End With
        
        
        For s = 1 To mRow3
            mStr1 = mRng3(s, 1)
            mDic3.Add mRng3(s, 1), ""
        Next
        
        s1 = 0
        
        For s = 1 To UBound(mRng3)
            mStr1 = mRng3(s, 2)
            If mDic3.Exists(mStr1) = True Then
                ReDim Preserve mData3(s1)
                mData3(s1) = mStr1 & ","
                s1 = s1 + 1
            End If
        Next
      
        .Range("c1").Resize(s1) = Application.Transpose(mData3)
        Set mRng = .Columns("c")
        With mRng
            .Replace ",", ""
        End With
        .Range("a7") = Join(mData1) & Join(mData2) & Join(mData3)
        
    End With      
   
   
End Sub

oobird

1. Sub yy()
   
2.     Dim d As Object, i%, r%, w$, s$, t, c As Range
   
3.     [a:c] = ""
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 6 To 10 Step 2
   
6.         For Each c In Cells(1, i).Resize(6, 2).SpecialCells(2)
   
7.             w = c.Value
   
8.             d(w) = d(w) + 1
   
9.         Next
   
10.         For Each t In d
    
11.             If d(t) = 1 Then d.Remove (t)
    
12.         Next
    
13.         If d.Count > 0 Then
    
14.             r = r + 1
    
15.             Cells(1, r).Resize(d.Count, 1) = Application.Transpose(d.keys)
    
16.             If s = "" Then s = Join(d.keys, "¡B") Else s = s & "¡B" & Join(d.keys, "¡B")
    
17.         End If
    
18.         d.RemoveAll
    
19.     Next
    
20.     [a7] = s
    
21. End Sub

½Æ»s¥N½X

pinklee

ÁÂÁ¡I¨â¦ì°ª¤âªº¸Ñµª¡A­ì¥»¥u­n¢Ï¢Ð¢ÑÄæ¦X¨Ö¡@²{¦b³s¤ñ¹ï³£¦³¤F¡@¥B«Ü²¼ä
¤@­Ó¦r¡@Æg¡@¡@