dechiuan999

§A¦n¡G
½Ð¸Õ¸Õ¬O§_¦X¾A
Sub aa()   
    Dim mSht As Worksheet
    Dim mRng As Range, E As Range
    Dim mDic As Object
    Dim mDic1 As Object
    Dim mKey1
    Dim m%
    Dim mDate As Date
    Dim mStr$
   
    Set mDic = CreateObject("Scripting.Dictionary")
    Set mDic1 = CreateObject("Scripting.Dictionary")
    Set mSht = Worksheets(1)
    With mSht
        Set mRng = .Range("b2:b19")
            For Each E In mRng
                mStr = E.Value & "," & E.Offset(, -1).Value
                    
                If E.Offset(, 1).Value > 0 Then
                    mDic(mStr) = mDic(mStr) + 1
                    mDic1(E.Value) = mDic1(E.Value)
                End If
               
            Next
            
            mDate = "2011/8/1"
            mKey1 = mDic1.Keys
           
            For Each E In mRng
               
                If mDic.Exists(E.Value & "," & E.Offset(, -1).Value) Then
                    
                    If E.Offset(, -1).Value = mDate And E.Offset(, 1).Value > 0 Then
                        E.Offset(, 2).Value = E.Value
                    End If
                End If
            
            Next
            m = 1
            For s = 0 To mDic1.Count - 1
                For Each E In mRng
                    If E.Offset(, 2) <> "" And E.Offset(, 2).Value = mKey1(s) Then
                    
                        E.Offset(, 2).Value = E.Offset(, 2).Value & m
                        m = m + 1
                    End If
                Next
                    m = 1
            Next
    End With
   
    Set mDic = Nothing
    Set mDic1 = Nothing
    Set mSht = Nothing
   
End Sub