E:G的数字(个位数0-9),对比H1:P1的数字(2位数,不重复的数值),如果H1:P1的数字在E:G里面包含了2个,那么就在H9开始对应的位置返回2,如是包含其它的数量就不需要返回;返回就从H9开始到P列,行数是E列不为空的行数;这是1张工作表的情况,工作表一共有"断断"和"1","2"…….一直到"20",共21个,都是一样的位置和格式;因为公式太大太慢了,所以请问这个代码用数组或字典的快速方法怎么写啊?求各位大师帮忙写一下.
æµè¯æ°æ®è¡¨ï¼
ç¨åºä»£ç å¾ï¼
æ§è¡ææï¼
ç¨åºææ¬ï¼
Option Explicit
Sub å®1()
Dim a(), d(1 To 9) As Object, e(), h(), i&, j&, n&, st As Worksheet
For Each st In Sheets '对ææå·¥ä½è¡¨
If st.Name <> "å¼å¥æ°æ®" Then
'åæ¢è¡¨ï¼å¹¶è·åå 容å°æ°ç»ä¸
st.Activate
'åæ°åºå¤çï¼å»ºç«åå ¸ï¼1-9表示H-Pçåå·
a = st.Range("h1:p1")
For i = 1 To UBound(a, 2)
If Not d(i) Is Nothing Then
d(i).RemoveAll
Else
Set d(i) = CreateObject("Scripting.Dictionary")
End If
a(1, i) = Trim(a(1, i))
For j = 1 To Len(a(1, i))
d(i)(Mid(a(1, i), j, 1)) = 1
Next j
Next i
'æ°æ®åºå¤ç
n = st.Cells(st.Rows.Count, "e").End(xlUp).Row 'Eåæåä¸è¡è¡å·
If n >= 9 Then 'è·³è¿ä¸è¶³9è¡ç表
e = st.Range(st.Cells(9, "e"), st.Cells(n, "g")) 'E:G - æºæ°ç»
h = st.Range(st.Cells(9, "h"), st.Cells(n, "p")) 'H:P - ç»ææ°ç»
For i = 1 To UBound(e)
For j = 1 To 3
e(i, j) = Trim(e(i, j))
Next j
If e(i, 1) <> "" And e(i, 2) <> "" And e(i, 3) <> "" Then
For j = 1 To UBound(a, 2)
If d(j)(e(i, 1)) + d(j)(e(i, 2)) + d(j)(e(i, 3)) >= 2 Then
h(i, j) = 2
Else
h(i, j) = Empty
End If
Next j
End If
Next i
'æ°ç»åå表
With st.Range(st.Cells(9, "h"), st.Cells(n, "p"))
.Select
.Value = h
End With
End If
End If
Next st
End Sub
追é®è°¢è°¢èå¸,ç»äºçå°ä½ äº.
æ个å°é®é¢,ææè¿å¥æ¹æäº If d(j)(e(i, 1)) + d(j)(e(i, 2)) + d(j)(e(i, 3)) = 0 Then
h(i, j) = 0
è¿ä¸ªæ¶å,å¦æH:Påä¸æä¸åæ¯å
¨ç©ºç,é£ä¹æä¹å¤æä¸å¨è¿ä¸åè¿å0å¢.æè¯äºå 次å ä¸å¥½.
If d(j)(e(i, 1)) + d(j)(e(i, 2)) + d(j)(e(i, 3)) = 0 Then
if a(1,j)"" then h(i, j) = 0 else h(i,j)=empty
èå¸,è¿ä¸ªä»£ç ææ³æ¹ä¸ä¸,æ¹ææºæ°ç»åç»ææ°ç»é½æ¯1åçæ åµ,è¿ä¸ªæºæ°ç»èæ¯æ¹ä¸å¥½,æåäºä¸ªæ°é®,æ¨å帮æçä¸ä¸.
Rem 方法一
Rem 在单元格H9中输入“=CNT($E9:$G9,H$1)”,填充单元格
Public Function CNT(rngV, rngH) 'rngV为E:G,rngH为H1:P1
Dim a, b
a = Left(rngH, 1) + 0
b = Right(rngH, 1) + 0 'rngH分割十位个位,文本转为数值
CNT = 0
For Each i In rngV
If i = a Then CNT = CNT + 1
If i = b Then CNT = CNT + 1
Next
If CNT <> 2 Then CNT = 0 '结果部位2时返回0
End Function
Rem 方法二
Rem 执行a过程
Sub CNTs(rngV, rngH, rngR) 'rngV为E:G,rngH为H1:P1,rngR返回区域
Dim RR, CC, arr, brr
RR = rngR.Rows.Count '行数
CC = rngR.Columns.Count '列数
ReDim arr(1 To CC), brr(1 To CC)'重设数组列数
Rem rngH分割十位个位,文本转为数值
For i = 1 To CC
arr(i) = Left(rngH(i), 1) + 0
brr(i) = Right(rngH(i), 1) + 0
Next
ReDim CNTs(1 To RR, 1 To CC)'重设结果数组大小
Rem 对比计数
For r = 1 To RR
For c = 1 To CC
For Each i In Array(rngV(r, 1), rngV(r, 2), rngV(r, 3))
If i = arr(c) Then CNTs(r, c) = CNTs(r, c) + 1
If i = brr(c) Then CNTs(r, c) = CNTs(r, c) + 1
Next
Next
Next
For r = 1 To RR
For c = 1 To CC
If CNTs(r, c) <> 2 Then CNTs(r, c) = 0 '结果部位2时返回0
Next
Next
Rem 导出结果
Range(rngR.Address) = CNTs
End Sub
Sub a()
'CNTs(rngV, rngH, rngR)rngV为E:G,rngH为H1:P1,rngR返回区域
Call CNTs(Range("A3:c10"), Range("m1:u1"), Range("m3:u10"))
End Sub