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

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

标签： excelvbaruntime-errortype-mismatch

Answer 1

每当涉及重复计数时，我都会使用dictionary object. 字典是一种增强型hashtable，只允许唯一的键值对。下面是一个示例，您可以根据需要进行修改。

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