- 帖子
- 231
- 主題
- 55
- 精華
- 0
- 積分
- 293
- 點名
- 0
- 作業系統
- winxp
- 軟體版本
- office2003
- 閱讀權限
- 20
- 性別
- 男
- 來自
- KEELUNG
- 註冊時間
- 2010-7-24
- 最後登錄
- 2018-8-28
|
2#
發表於 2011-10-2 12:29
| 只看該作者
你好：
請試試是否合適
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 |
|
發表於 2011-10-4 21:30
| 
