dechiuan999

§A¦n
½Ð¸Õ¸Õ¦p¤U
Sub aa()

    '½Ð¥ý¥Ñ¤u¨ã³]©wMicrosoft Scripting Rungtime
   
    Dim mSht As Worksheet
    Dim mDic As Scripting.Dictionary
    Dim mKey, mItem
    Dim mArr
    Dim mRng As Range, E As Range
    Dim s%, s1%
   
   
    Set mDic = CreateObject("scripting.dictionary")
    mArr = Array("a", "b")
   
    For i = 0 To 1
        With Workbooks.Open(ThisWorkbook.Path & "\" & mArr(i) & ".xlsx")
            With .Sheets(1)
                Set mRng = .Range("i2:i" & .[i65536].End(xlUp).Row)
            End With
               
                For Each E In mRng
                    If mDic.Exists(E.Value) = False Then
                        mDic(E.Value) = 1
                    Else
                        mDic(E.Value) = mDic(E.Value) + 1
                    End If
                    
                Next
               
                mKey = mDic.Keys
                mItem = mDic.Items
               
            .Close
        End With
    Next
   
    For i = 0 To mDic.Count - 1
        If mKey(i) = "d" Then
            s = mItem(i)
        End If
        
        If mKey(i) = "e" Then
            s1 = mItem(i)
        End If
        
    Next
      
    For i = 0 To mDic.Count - 1
        
        If mKey(i) = "f" Then
            mItem(i) = mItem(i) + s + s1
        End If
    Next
   
    'Set mRng = Range("b3:b" & [b65536].End(xlUp).Row)     '
    '
    'For Each E In mRng                     'ª©¥D¤j¤j¬O§_¥iÀ°¤p§Ì¸Ñ´b¬°¦ó¦¹»yªkµLªk¥¿½T¨ú¥Xdictionaryªºitems­È©O¡H
    '    E.Offset(, 1) = mDic(E.Value)      '¦¹³¡¥÷¦³°ÝÃD
    'Next
   
    For i = 0 To mDic.Count - 1
        Set mRng = Columns("b").Find(mKey(i), lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext)
        If Not mRng Is Nothing Then
            mRng.Offset(, 1) = mItem(i)
        End If
        
    Next
        
End Sub