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