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

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

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


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

§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

TOP

  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

TOP

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

TOP

        ÀR«ä¦Û¦b : «Î¼e¤£¦p¤ß¼e¡C
ªð¦^¦Cªí ¤W¤@¥DÃD