函数IF+COUNTIFS转VBA代码

小曹369

各位老师，函数IF+COUNTIFS可以使用，但因表格数据很多及用函数太卡了，是否可以帮忙VBA小代码，谢谢了

mjm04

不要引用整列，改成引用范围！！！

目测这个函数应该卡不到那去啊~~~

loirol

翁知江安

Sub test90()
Dim i, k, irow
Dim arr, brr
Dim d1 As Object
Dim d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
irow = Sheets("生产工单").[b65536].End(xlUp).Row
arr = Sheets("生产工单").Range("a1:r" & irow)
For i = 2 To UBound(arr)
  If Not d1.exists(arr(i, 2)) Then
  d1(arr(i, 2)) = 1
   Else
   d1(arr(i, 2)) = d1(arr(i, 2)) + 1
  End If
  If Not d2.exists(arr(i, 2) & arr(i, 15)) Then
  d2(arr(i, 2) & arr(i, 15)) = 1
   Else
   d2(arr(i, 2) & arr(i, 15)) = d2(arr(i, 2) & arr(i, 15)) + 1
  End If
Next
ReDim brr(1 To irow - 1, 1 To 1)
For k = 2 To UBound(arr)
  If d1(arr(k, 2)) = d2(arr(k, 2) & arr(k, 15)) Then
      brr(k - 1, 1) = "齐套"
      Else
      brr(k - 1, 1) = "不齐套"
  End If
Next
Sheets("生产工单").[p2].Resize(irow - 1, 1) = brr
MsgBox "ok"
End Sub

翁知江安

以上数据仅供参考，欢迎批评指正。

ykcbf1100

附件供参考，字典

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.11.15
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With ActiveSheet
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         c = .UsedRange.Columns.Count
   
7.         arr = .[a1].Resize(r, c)
   
8.         For i = 2 To UBound(arr)
   
9.             s = arr(i, 2)
   
10.             If Not d.exists(s) Then
    
11.                 d(s) = arr(i, 15)
    
12.             Else
    
13.                 d(s) = IIf(InStr(d(s), arr(i, 15)), d(s), d(s) & "," & arr(i, 15))
    
14.             End If
    
15.         Next
    
16.         For i = 2 To UBound(arr)
    
17.             s = arr(i, 2)
    
18.             arr(i, 16) = IIf(InStr(d(s), "欠料"), "不齐套", "齐套")
    
19.         Next
    
20.         .[p1].Resize(r, 1) = Application.Index(arr, 0, 16)
    
21.     End With
    
22.     Set d = Nothing
    
23.     Application.ScreenUpdating = True
    
24.     MsgBox "OK！"
    
25. End Sub
    

复制代码

翁知江安

不好意思，刚刚那个有点问题，修改后重传

翁知江安

Sub test90()
Dim i, k, irow
Dim arr, brr
Dim d1 As Object
Dim d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
irow = Sheets("生产工单").[b65536].End(xlUp).Row
arr = Sheets("生产工单").Range("a1:r" & irow)
For i = 2 To UBound(arr)
  If Not d1.exists(arr(i, 2)) Then
  d1(arr(i, 2)) = 1
   Else
   d1(arr(i, 2)) = d1(arr(i, 2)) + 1
  End If
  If Not d2.exists(arr(i, 2) & arr(i, 15)) And arr(i, 15) = "不欠" Then
  d2(arr(i, 2) & arr(i, 15)) = 1
   Else
   d2(arr(i, 2) & arr(i, 15)) = d2(arr(i, 2) & arr(i, 15)) + 1
  End If
Next
ReDim brr(1 To irow - 1, 1 To 1)
For k = 2 To UBound(arr)
  If d1(arr(k, 2)) = d2(arr(k, 2) & arr(k, 15)) Then
      brr(k - 1, 1) = "齐套"
      Else
      brr(k - 1, 1) = "不齐套"
  End If
Next
Sheets("生产工单").[p2].Resize(irow - 1, 1) = brr
MsgBox "ok"
End Sub

翁知江安

以上仅供参考，欢迎批评指正