宏检查列并根据值计算行数，并检查列的范围是否包含任何值

Question

我正在学习excel中的宏，我在这里尝试两件事。

1. 查找列中不同值的计数。我可以使用这个链接宏来检查列并根据

   值计算行数

2. 现在我想要检查特定列范围是否有任何值。例如，如果列A包含单词"sample";3次，然后我需要检查B列从B1到B3 (B3，因为样本重复了3次)，并需要找到是否有任何单元格包含B1到B3之间的值。

我试图俱乐部这两个宏，这将给我所需的输出。但无法实现。请协助。

'Set reference to Microsoft Scripting Runtime
'  or use late binding
Option Explicit
Sub UniqueCounts()
Dim myD As Dictionary
Dim vArr As Variant
Dim WS As Worksheet
Dim I As Long, sKey As String, v As Variant, s As String
Set WS = ThisWorkbook.Worksheets("sheet1")
With WS
vArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
Set myD = New Dictionary
myD.CompareMode = TextCompare
For I = 1 To UBound(vArr)
sKey = vArr(I, 1)
If Not myD.Exists(sKey) Then
myD.Add Key:=sKey, Item:=1
Else
myD(sKey) = myD(sKey) + 1
End If
Next I
For Each v In myD
s = s & vbLf & v & " (" & myD(v) & ")"
Next v
s = Mid(s, 2)
MsgBox (s)
End Sub

Sub TestIsEmpty()
If WorksheetFunction.CountA(Range("B1:B3")) > 0 Then
MsgBox "Not Empty"
Else
MsgBox "Empty"
End If
End Sub

Answer 1

我认为这是你所说的，但可能不是你想要的(即我不确定我是否正确理解了这个问题)。我避免使用dictionary方法，因为我以前从未使用过它。

Dim numtimes As Double
Option Explicit
Sub uniquevalues()
Dim rg As Range
Dim rows As Integer
Dim cell As Range
Dim dc As Double
Set rg = [a1].CurrentRegion.Offset(1, 0)
Set rg = rg.Resize(rg.rows.Count - 1, 1)

For Each cell In rg
numtimes = WorksheetFunction.CountIf(rg, cell.Value)
dc = dc + (1 / numtimes)
checkcolB
Next
MsgBox "The number of distinct records is " & dc
End Sub
Sub checkcolB()
Dim rg2 As Range
Set rg2 = Range("b1:b" & numtimes)
If WorksheetFunction.CountA(rg2) > 0 Then
MsgBox "Not Empty"
Else
MsgBox "Empty"
End If
End Sub