dechiuan999

§A¦n¡G
  ½Ð°Ý§Aªº­pºâ°ò¦¬°¦ó©O¡H
¦pªG¥H0002¥X²{¤£­«ÂЦ¸¼Æ¬°=2®É¡A
·Q¥²¬O¥HA¤ÎB¦X¨Ö¬°KEY­È¡A
0002A1 ¤@¦¸
0002B1 ¤T¦¸¡A¤£­«ÂЦ¸¼Æ¬°¤G
¨º0001À³¬°1¦¸¤~¦X²z¡C
0001¦p¦ó­pºâ¤£­«ÂЦ¸¼Æ¬°=3©O¡H
¦pªG¤W­z±À²z¥¿½T®É¡A½Ð¸Õ¸Õ¤U¦C»yªk
Sub aa()
   
    '½Ð¥ý¥Ñ¤u¨ã¦C¤Þ¥ÎMicrosoft Scripting Rungtime
   
    Dim mDic As Scripting.Dictionary
    Dim mSht As Worksheet
    Dim mRng As Range, mRng1 As Range
    Dim E As Range
    Dim mTmp, mVal
    Dim i%
   
    Set mDic = CreateObject("scripting.dictionary")
    Set mSht = Worksheets(1)
    With mSht
        Set mRng = .Range("a1", Range("a" & .Rows.Count).End(xlUp))
            For Each E In mRng
                If Not E.Value = Empty Then
                    If Not mDic.Exists(E.Value & "_" & E.Offset(, 1).Value) Then
                        mDic(E.Value & "_" & E.Offset(, 1).Value) = 1
                        
                    Else
                        mDic(E.Value & "_" & E.Offset(, 1).Value) = mDic(E.Value & "_" & E.Offset(, 1).Value) + 1
                    End If
                    
                End If
            Next
            
            For Each E In mRng
                E.Offset(, 3).Value = E.Value & "_" & E.Offset(, 1).Value
            Next
            
            mKey = mDic.Keys
         
            For i = LBound(mKey) To UBound(mKey)
               mVal = mDic(mKey(i))
               If mVal > 1 Then
                  Set mRng1 = mSht.Columns(4).Find(what:=mKey(i), lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext)
                  If Not mRng1 Is Nothing Then
                    mRng1.Offset(, -1).Value = mVal - 1
                  End If
                End If
            Next
            .Columns(4).ClearContents            
    End With            
End Sub