A列每个单元格都有一个数数据，它们有的相同，有点不同，B列的单元格中每

李泽？

急！急！
A列每个单元格都有一个数据，它们有的相同，有的不同，B列单元格中有的一个数据，有的有多个数据如何让A列单元格中的数据如果与B列单元格中的数据比对，如果B列单元格中的数据含有A列的数据则返回真，否则返回假，用vba编写程序.如图当a1或a4或a5与b1比较时为真，当a2或a3或a6与B1比较时为假，谢谢各位大神！

Sub arr()
Dim arr(), arr1(), arr2(), arr3(1 To 1000), t, pjf!, jgrs%, lhrs%, ysrs%, dfrs%
a = Sheet1.Cells(2, Columns.Count).End(xlToLeft).Column
b = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row
c = Sheet2.Cells(2, Columns.Count).End(xlToLeft).Column
d = Sheet2.Cells(Rows.Count, 3 * t + 1).End(xlUp).Row
arr = Sheet1.Range(Sheet1.[c3], Sheet1.Cells(b, a))
arr1 = Sheet2.Range(Sheet2.Cells(3, 3 * t + 1), Sheet2.Cells(d, 3 * t + 3))
arr2 = Sheet3.Range(Sheet3.[e3], Sheet3.[m6])
r = UBound(arr1)
1:
For j = 1 To UBound(arr1)
k = 0: skrs = 0: jgrs = 0: lhrs = 0: ysrs = 0: dfrs = 0
For i = 1 To UBound(arr)
[color=Red]e = arr(i, 2) Like arr1(j, 3 + 2 * g)（就是这一句，我想用like函数，但对10以上的数值又不能用）
If arr(i, 1) = arr1(j, 1) And e = True Then k = k + 1: arr3(k) = arr(i, 4 + g)
Next i
For n = 1 To k
'Stop
If arr3(n) > 0 Then skrs = skrs + 1
If arr3(n) >= arr2(1, 2 + g) Then jgrs = jgrs + 1
If arr3(n) >= arr2(2, 2 + g) Then lhrs = lhrs + 1
If arr3(n) >= arr2(3, 2 + g) Then ysrs = ysrs + 1
If arr3(n) <= arr2(4, 2 + g) And arr3(n) > 0 Then dfrs = dfrs + 1
Next n
Sheet4.Cells(4 + m, "b") = arr1(j, 1)
'Sheet4.Cells(4 + m, "d") = skrs
Sheet4.Cells(4 + m, "e") = arr1(j, 2)
Sheet4.Cells(4 + m, "d") = skrs
Sheet4.Cells(4 + m, "c") = k
If k = 0 Then GoTo 100
Sheet4.Cells(4 + m, "f") = WorksheetFunction.Average(arr3)
Sheet4.Cells(4 + m, "h") = jgrs
Sheet4.Cells(4 + m, "i") = Format(jgrs / skrs * 100, ".00")
Sheet4.Cells(4 + m, "k") = lhrs
Sheet4.Cells(4 + m, "l") = Format(lhrs / skrs * 100, ".00")
Sheet4.Cells(4 + m, "n") = ysrs
Sheet4.Cells(4 + m, "o") = Format(ysrs / skrs * 100, ".00")
Sheet4.Cells(4 + m, "q") = dfrs
Sheet4.Cells(4 + m, "r") = Format(dfrs / skrs * 100, ".00")
Erase arr3
100:
m = m + 1

Next j
g = g + 1
If g < 9 Then GoTo 1
Stop
Dim Number As Double, x%, y%, f%, p
h = Sheet1.Cells(2, Columns.Count).End(xlToLeft).Column
For y = 0 To 4
For x = 4 To 3 + r
Number = Worksheets("sheet4").Cells(x, 6 + 3 * y).Value
Set myrange = Worksheets("Sheet4").Range(Cells(4, 6 + 3 * y), Cells(3 + r, 6 + 3 * y))
p = Application.Rank(Number, myrange, 0)
Sheet4.Cells(x, 7 + 3 * y) = p
Next x
Next y
'g = g + 1
   'If s < 9 Then GoTo 1
End Sub

醉眼看尘世

只和B1比较？肯定还要和B2比较哇。那比较结果就有多份了。你模拟点结果来看看

ykcbf1100

你再急，也上个附件吧。

没有附件就贴个图吧，供参考。。。

一招秒杀

  两个函数 搞定。

李泽？

醉眼看尘世 发表于 2024-8-27 19:11
只和B1比较？肯定还要和B2比较哇。那比较结果就有多份了。你模拟点结果来看看

Sub arr()
Dim arr(), arr1(), arr2(), arr3(1 To 1000), t, pjf!, jgrs%, lhrs%, ysrs%, dfrs%
a = Sheet1.Cells(2, Columns.Count).End(xlToLeft).Column
b = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row
c = Sheet2.Cells(2, Columns.Count).End(xlToLeft).Column
d = Sheet2.Cells(Rows.Count, 3 * t + 1).End(xlUp).Row
arr = Sheet1.Range(Sheet1.[c3], Sheet1.Cells(b, a))
arr1 = Sheet2.Range(Sheet2.Cells(3, 3 * t + 1), Sheet2.Cells(d, 3 * t + 3))
arr2 = Sheet3.Range(Sheet3.[e3], Sheet3.[m6])
r = UBound(arr1)
1:
For j = 1 To UBound(arr1)
k = 0: skrs = 0: jgrs = 0: lhrs = 0: ysrs = 0: dfrs = 0
For i = 1 To UBound(arr)
e = arr(i, 2) Like arr1(j, 3 + 2 * g)（就是这一句，我想用like函数，但对10以上的数值又不能用）
If arr(i, 1) = arr1(j, 1) And e = True Then k = k + 1: arr3(k) = arr(i, 4 + g)
Next i
For n = 1 To k
'Stop
If arr3(n) > 0 Then skrs = skrs + 1
If arr3(n) >= arr2(1, 2 + g) Then jgrs = jgrs + 1
If arr3(n) >= arr2(2, 2 + g) Then lhrs = lhrs + 1
If arr3(n) >= arr2(3, 2 + g) Then ysrs = ysrs + 1
If arr3(n) <= arr2(4, 2 + g) And arr3(n) > 0 Then dfrs = dfrs + 1
Next n
Sheet4.Cells(4 + m, "b") = arr1(j, 1)
'Sheet4.Cells(4 + m, "d") = skrs
Sheet4.Cells(4 + m, "e") = arr1(j, 2)
Sheet4.Cells(4 + m, "d") = skrs
Sheet4.Cells(4 + m, "c") = k
If k = 0 Then GoTo 100
Sheet4.Cells(4 + m, "f") = WorksheetFunction.Average(arr3)
Sheet4.Cells(4 + m, "h") = jgrs
Sheet4.Cells(4 + m, "i") = Format(jgrs / skrs * 100, ".00")
Sheet4.Cells(4 + m, "k") = lhrs
Sheet4.Cells(4 + m, "l") = Format(lhrs / skrs * 100, ".00")
Sheet4.Cells(4 + m, "n") = ysrs
Sheet4.Cells(4 + m, "o") = Format(ysrs / skrs * 100, ".00")
Sheet4.Cells(4 + m, "q") = dfrs
Sheet4.Cells(4 + m, "r") = Format(dfrs / skrs * 100, ".00")
Erase arr3
100:
m = m + 1

Next j
g = g + 1
If g < 9 Then GoTo 1
Stop
Dim Number As Double, x%, y%, f%, p
h = Sheet1.Cells(2, Columns.Count).End(xlToLeft).Column
For y = 0 To 4
For x = 4 To 3 + r
Number = Worksheets("sheet4").Cells(x, 6 + 3 * y).Value
Set myrange = Worksheets("Sheet4").Range(Cells(4, 6 + 3 * y), Cells(3 + r, 6 + 3 * y))
p = Application.Rank(Number, myrange, 0)
Sheet4.Cells(x, 7 + 3 * y) = p
Next x
Next y
'g = g + 1
   'If s < 9 Then GoTo 1
End Sub

李泽？

ykcbf1100 发表于 2024-8-27 19:32
你再急，也上个附件吧。

没有附件就贴个图吧，供参考。。。

Sub arr()
Dim arr(), arr1(), arr2(), arr3(1 To 1000), t, pjf!, jgrs%, lhrs%, ysrs%, dfrs%
a = Sheet1.Cells(2, Columns.Count).End(xlToLeft).Column
b = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row
c = Sheet2.Cells(2, Columns.Count).End(xlToLeft).Column
d = Sheet2.Cells(Rows.Count, 3 * t + 1).End(xlUp).Row
arr = Sheet1.Range(Sheet1.[c3], Sheet1.Cells(b, a))
arr1 = Sheet2.Range(Sheet2.Cells(3, 3 * t + 1), Sheet2.Cells(d, 3 * t + 3))
arr2 = Sheet3.Range(Sheet3.[e3], Sheet3.[m6])
r = UBound(arr1)
1:
For j = 1 To UBound(arr1)
k = 0: skrs = 0: jgrs = 0: lhrs = 0: ysrs = 0: dfrs = 0
For i = 1 To UBound(arr)
e = arr(i, 2) Like arr1(j, 3 + 2 * g)（就是这一句，我想用like函数，但对10以上的数值又不能用）
If arr(i, 1) = arr1(j, 1) And e = True Then k = k + 1: arr3(k) = arr(i, 4 + g)
Next i
For n = 1 To k
'Stop
If arr3(n) > 0 Then skrs = skrs + 1
If arr3(n) >= arr2(1, 2 + g) Then jgrs = jgrs + 1
If arr3(n) >= arr2(2, 2 + g) Then lhrs = lhrs + 1
If arr3(n) >= arr2(3, 2 + g) Then ysrs = ysrs + 1
If arr3(n) <= arr2(4, 2 + g) And arr3(n) > 0 Then dfrs = dfrs + 1
Next n
Sheet4.Cells(4 + m, "b") = arr1(j, 1)
'Sheet4.Cells(4 + m, "d") = skrs
Sheet4.Cells(4 + m, "e") = arr1(j, 2)
Sheet4.Cells(4 + m, "d") = skrs
Sheet4.Cells(4 + m, "c") = k
If k = 0 Then GoTo 100
Sheet4.Cells(4 + m, "f") = WorksheetFunction.Average(arr3)
Sheet4.Cells(4 + m, "h") = jgrs
Sheet4.Cells(4 + m, "i") = Format(jgrs / skrs * 100, ".00")
Sheet4.Cells(4 + m, "k") = lhrs
Sheet4.Cells(4 + m, "l") = Format(lhrs / skrs * 100, ".00")
Sheet4.Cells(4 + m, "n") = ysrs
Sheet4.Cells(4 + m, "o") = Format(ysrs / skrs * 100, ".00")
Sheet4.Cells(4 + m, "q") = dfrs
Sheet4.Cells(4 + m, "r") = Format(dfrs / skrs * 100, ".00")
Erase arr3
100:
m = m + 1

Next j
g = g + 1
If g < 9 Then GoTo 1
Stop
Dim Number As Double, x%, y%, f%, p
h = Sheet1.Cells(2, Columns.Count).End(xlToLeft).Column
For y = 0 To 4
For x = 4 To 3 + r
Number = Worksheets("sheet4").Cells(x, 6 + 3 * y).Value
Set myrange = Worksheets("Sheet4").Range(Cells(4, 6 + 3 * y), Cells(3 + r, 6 + 3 * y))
p = Application.Rank(Number, myrange, 0)
Sheet4.Cells(x, 7 + 3 * y) = p
Next x
Next y
'g = g + 1
   'If s < 9 Then GoTo 1
End Sub

一招秒杀

李泽？ 发表于 2024-8-28 02:12
Sub arr()
Dim arr(), arr1(), arr2(), arr3(1 To 1000), t, pjf!, jgrs%, lhrs%, ysrs%, dfrs%
a = Sh ...

为什么楼上两个函数轻松秒杀的问题，为何还非要写60多行代码，结果还是解决不了？我们不仅要解决问题，而且要简单 高效 快速 准确 低成本，未来还要好维护，易扩展，算法是灵魂，没有算法加持的代码就是 Shi 山，追求精品，不要垃圾。