在具有可变范围的列中查找重复项并在单独的列中计数

Question

我正在尝试识别可变范围列中的所有重复项。我找到了这段代码：

Public Sub assignSeq()

targetRng = "A2:A14" 'Define the Range you want to assign number

For Each Rng In Range(targetRng)

Rng.Offset(0, 1).Value = 

Application.WorksheetFunction.CountIf(Range(Split(targetRng, ":")(0) & ":" & Rng.Address), Rng.Value)

Next

End Sub

我试图修改它，希望我可以使用它来处理具有可变范围的列（我将在许多工作簿中将此代码与其他代码一起使用，所以我不能将它与设置范围，即 E2:E15).

Sub assignSeq()

Dim lastRow As Long

Dim targetRng As Range

Dim rng As Range

'Column E won't be the same length every file that this macro is ran in. Column B is used to tell how long column E is.

lastRow = Cells(Rows.Count, "B").End(xlUp).Row

'Define the Range you want to assign number

Set targetRng = Range("E2:E5" & lastRow)

Set rng = Range("E2:E5" & lastRow)

 For Each rng In Range("E2:E5" & lastRow)
 rng.Offset(0, 1).Value = 

Application.WorksheetFunction.CountIf(Range(Split(targetRng, ":")(0) & ":" & rng.Address), rng.Value)

 Next

End Sub

当我运行代码时，我得到运行-时间错误“13”：类型不匹配。

下面，F 列 是我希望此代码在该列中一直执行的操作，无论它有多长。 G 列由我编写并运行的单独代码完成，因此我不一定要为此寻求帮助，而是想展示我最终要完成的工作。

Column E           Column F     Column G  

PermAssetNumber    Count        PermAssetNumber w/Count
B02061               1          B02061
B02061               2          B02061_2
B02079               1          B02079
B02081               1          B02081
B02081               2          B02081_2
B02063               1          B02063
B02070               1          B02070
B02062               1          B02062
B02081               3          B02081_3
B02086               1          B02086
B02087               1          B02087
B02088               1          B02088
B02089               1          B02089
B02090               1          B02090
B02091               1          B02091
B02065               1          B02065
B02082               1          B02082
B02083               1          B02083
B02048               1          B02048
B02081               4          B02081_4

Answer 1

试试这个。

您有一些错别字 Range("E2:E5" & lastRow) - 第 5 个错误。

Split(targetRng, ":") 是错误的，因为 Targetrng 是一个范围而不是字符串，所以我们使用它的 Address 属性这是一个字符串。

Sub assignSeq()

Dim lastRow As Long
Dim targetRng As Range
Dim rng As Range

lastRow = Cells(Rows.Count, "B").End(xlUp).Row

Set targetRng = Range("E2:E" & lastRow)

For Each rng In targetRng
    rng.Offset(0, 1).Value = _
        Application.WorksheetFunction.CountIf(Range(Split(targetRng.Address, ":")(0) & ":" & rng.Address), rng.Value)
Next

End Sub

Answer 2

每当涉及重复计数时，我都会使用 dictionary object。该字典是一个增强的 hashtable，只允许唯一的 key-value 对。下面是一个示例，您可以修改它以满足您的需要。

Option Explicit

Public Sub RunningCounts(ByVal strWBName As String, ByVal strWSName As String, _
                         ByVal strTargteRngAddress As String, ByVal strColToFindLR As String)

 Dim objDict As Object
 Dim objWB As Workbook
 Dim objWS As Worksheet
 Dim rngToLookUp As Range
 Dim lngLastRow As Long, i As Long
 Dim arrySheet As Variant, arryOut() As Variant
 Dim varKey As Variant

    Set objWB = Workbooks(strWBName)
    Set objWS = objWB.Worksheets(strWSName)
    lngLastRow = objWS.Cells(objWS.Rows.Count, strColToFindLR).End(xlUp).Row
    Set rngToLookUp = objWS.Range(strTargteRngAddress & lngLastRow)

    If rngToLookUp.Columns.Count > 1 Then
        MsgBox "The input Range cannot be more than" _
        & " a single column.", vbCritical + vbOKOnly, "Error:" _
        & " Invalid Range Dimensions"
        Exit Sub
    End If

    arrySheet = rngToLookUp.Value2

        ReDim arryOut(1 To UBound(arrySheet, 1), 1 To 1)

        Set objDict = CreateObject("Scripting.Dictionary")

            For i = LBound(arrySheet, 1) To UBound(arrySheet, 1)
                'each time a key occurs, add one to the item associated with that key
               varKey = Trim(arrySheet(i, 1))
               If Not objDict.Exists(varKey) Then
                  objDict(varKey) = 1
                  arryOut(i,1) = 1
               Else
                  objDict(varKey) = objDict(varKey) + 1  
                  arryOut(i,1) = objDict.Item(varKey)             
               End If
               varKey = Empty 
            Next i

    rngToLookUp.Offset(0, 1).Resize(UBound(arryOut, 1), _
    UBound(arryOut, 2)).Value2 = arryOut

End Sub


Public Sub ExecuteRunningCount()

 Dim strTgtWBName As String
 Dim strgtWSName As String
 Dim strTgtRangeAddress As String
 Dim strTgtColToLookInLR As String

    strTgtWBName = "SomeWBNamew.xlsm" 
    strTgtWSName = "SheetName"
    strTgtRangeAddress = "A2:A"
    strTgtColToLookInLR = "A"

    Call RunningCounts(strTgtWBName, strTgtWSName, strTgtRangeAddress, strTgtColToLookInLR )

End Sub

在具有可变范围的列中查找重复项并在单独的列中计数

Find Duplicates in a Column with a Variable Range and Count in a Separate Column

excel

vba

runtime-error

type-mismatch