|
bhurdx 发表于 2013-5-26 23:00
我的意思是假设有二组数合条件,结果它只会显示一组数,例附件结果是111,505,但它显示两个111
我知道了- Sub TIQU()
- On Error Resume Next
- Dim Arr1
- Dim Row1, D1, I1, J1, Arr11(), Arr12(), Arr13()
- Set D1 = CreateObject("scripting.dictionary")
- Set d2 = CreateObject("scripting.dictionary")
- Row1 = Range("I" & Rows.Count).End(xlUp).Row
- Arr1 = Range("I4:S" & Row1)
- For j = 1 To UBound(Arr1, 2) - 5
- For p = 1 To 6
- For i = 1 To UBound(Arr1)
- If p = 1 Then
- If Not D1.exists(Arr1(i, j)) Then
- m = m + 1
- ReDim Preserve Arr11(1 To 7, 1 To m)
- D1(Arr1(i, j)) = m
- Arr11(1, m) = Arr1(i, j)
- End If
- End If
- Arr11(p + 1, D1(Arr1(i, j + p - 1))) = Arr11(p + 1, D1(Arr1(i, j + p - 1))) + 1
- Next i
- Next p
- For i = 1 To m
- y = False
- For j2 = 2 To 7
- If Arr11(j2, i) >= 1 Then
- If Not d2.exists(Arr11(j2, i)) Then
- m2 = m2 + 1
- d2(Arr11(j2, i)) = m2
- ReDim Preserve Arr12(1 To 2, 1 To m2)
- Arr12(1, m2) = Arr11(1, i)
- End If
- Arr12(2, d2(Arr11(j2, i))) = Arr12(2, d2(Arr11(j2, i))) + 1
- Else
- y = True
- End If
- Next j2
- If m2 = 2 And y = False Then
- M3 = M3 + 1
- ReDim Preserve Arr13(1 To 1, 1 To M3)
- Arr13(1, M3) = Arr11(1, i)
- End If
- Erase Arr12
- m2 = 0
- d2.RemoveAll
- Next i
- m = 0
- Erase Arr11
- D1.RemoveAll
- Next j
- With Sheets(2).Range("A2").Resize(M3, 1)
- .Value = Application.Transpose(Arr13)
- End With
- End Sub
复制代码 |
|