字典取值补充说明

hy397556 · 发表于 2024-11-19 19:12

字典到满足条件值.rar (12.81 KB, 下载次数: 10)
上个贴，说明不够详细，再补充一下，麻烦各位老师了

shiruiqiang · 发表于 2024-11-19 19:30

这又不用字典

Qs18 · 发表于 2024-11-19 19:35

Sub qs()
Dim arr, i
With Sheet1
x = .[l1].Value: y = .[l2].Value
arr = .Range("a1").CurrentRegion.Value
ReDim brr(1 To UBound(arr), 1 To 1)
For i = 2 To UBound(arr)
m = 0
For j = 2 To y + 1
If arr(i, j) = x Then
m = m + 1
Else
Exit For
End If
If m = y Then n = n + 1: brr(n, 1) = arr(i, 1)
Next j
Next i
.Range("k7").Resize(n, 1) = brr
End With
End Sub

复制代码

Qs18 · 发表于 2024-11-19 19:36

试试...........

Qs18 · 发表于 2024-11-19 19:37

试试..............

chxw68 · 发表于 2024-11-19 19:37

Sub test()
Dim r%, i%
Dim arr, brr
With Worksheets("sheet1")
tj = .Range("l1:l2")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:i" & r)
ReDim brr(1 To UBound(arr), 1 To 1)
m = 0
For i = 1 To UBound(arr)
For j = 2 To tj(2, 1) + 1
If arr(i, j) <> tj(1, 1) Then
Exit For
End If
Next
If j > tj(2, 1) + 1 Then
m = m + 1
brr(m, 1) = arr(i, 1)
End If
Next
.Range("l6:l" & .Rows.Count).ClearContents
If m > 0 Then
.Range("l6").Resize(m, 1) = brr
End If
End With
End Sub

复制代码

shiruiqiang · 发表于 2024-11-19 19:38

字典用法

chxw68 · 发表于 2024-11-19 19:38

这个问题用不到字典。

quqiyuan · 发表于 2024-11-19 19:42

参与一下，仅供参考。。。。

quqiyuan · 发表于 2024-11-19 19:45

代码如下。。。。。
Sub test()
Dim wb As Workbook, sht As Worksheet
Set wb = ThisWorkbook
Set sht = wb.Sheets("sheet1")
With sht
      f = .[l1]
      r = .Cells(Rows.Count, 1).End(3).Row
      arr = .Range("a2:a" & r).Resize(, .[l2] + 1)
      ReDim brr(1 To UBound(arr), 0)
      n = 0
      For i = 1 To UBound(arr)
         m = 0
         For j = 2 To UBound(arr, 2)
            If arr(i, j) = f Then
                  m = m + 1
            End If
            If m = .[l2] Then n = n + 1: brr(n, 0) = arr(i, 1)
         Next
      Next
      .[p6].CurrentRegion.ClearContents
      .[p6].Resize(n) = brr
End With
Beep
End Sub

		自动登录	找回密码
密码			免费注册

[求助] 字典取值补充说明

评分

评分

评分

评分

评分

评分