时间戳

首页 > 解决方案 > 我需要一个 VBA 将行中的唯一值添加到列中

excel - 我需要一个 VBA 将行中的唯一值添加到列中

问题描述

我正在寻找一个 VBA 来自动将行中的唯一值添加到 D 列。我目前有一个宏来计算行中的唯一值并在上面添加相应数量的空白行。

如果 C 列的值 >0，请在 D 列的 R:AQ 中列出所有唯一值。行范围应为 R:AQ。

我在宏之前和之后添加了我希望宏执行的操作。谢谢！

前

后

标签： excelvba

解决方案

列的唯一行值

  • 行的插入、列的写入C和唯一值的写入应该在同一个过程中完成（在随附过程的帮助下）。你有点获得了独特的价值两次：计数和写作时，冒着得到不同结果的风险。因此，共享您的“插入”代码至关重要。
  • 只有当列中的值正确时，以下解决方案才能正常工作C。如果唯一值比列中指示的多C，它仍然可以工作，但只会C写入列中指示的唯一值的第一个数量。如果唯一值少于列中指示的数量C，则会出现一个带有当前错误描述的消息框：它将不起作用。
Option Explicit

Sub WriteUnique()
    
    On Error GoTo ClearError
    
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    If lRow < 2 Then Exit Sub
    
    Dim lrg As Range: Set lrg = ws.Range(ws.Cells(2, "C"), ws.Cells(lRow, "C"))
    Dim rCount As Long: rCount = lrg.Rows.Count
    Dim lData As Variant
    If rCount = 1 Then
        ReDim lData(1 To 1, 1 To 1): lData(1, 1) = lrg.Value
    Else
        lData = lrg.Value
    End If
    
    Dim urg As Range: Set urg = lrg.EntireRow.Columns("R:AQ")
    Dim ucCount As Long: ucCount = urg.Columns.Count
    Dim uData As Variant: uData = urg.Value
    
    Dim dData As Variant: ReDim dData(1 To rCount, 1 To 1)
    Dim tDat As Variant
    
    Dim r As Long: r = rCount
    Dim uCount As Long
    Dim n As Long
    
    Do Until r < 2
        uCount = lData(r, 1)
        If uCount > 0 Then
            tDat = ArrUniqueRow(uData, r)
            If Not IsEmpty(tDat) Then
                r = r - uCount
                For n = 0 To uCount - 1
                    dData(r + n, 1) = tDat(n)
                Next n
            End If
        End If
        r = r - 1
    Loop
    
    ws.Cells(2, "D").Resize(rCount).Value = dData

ProcExit:
    Exit Sub
ClearError:
    MsgBox Err.Description
    Resume ProcExit
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the unique values from a row ('RowNumber')
'               of a 2D one-based array ('Data') to a 1D zero-based array,
'               excluding error values and blanks.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrUniqueRow( _
    ByVal Data As Variant, _
    ByVal RowNumber As Long, _
    Optional ByVal CompareMethod As VbCompareMethod = vbTextCompare) _
As Variant
    
    If IsEmpty(Data) Then Exit Function
    If RowNumber < 0 Then Exit Function
    If RowNumber > UBound(Data, 1) Then Exit Function
    
    With CreateObject("Scripting.Dictionary")
        .CompareMode = CompareMethod
        
        Dim Key As Variant
        Dim c As Long
        For c = 1 To UBound(Data, 2)
            Key = Data(RowNumber, c)
            If Not IsError(Key) Then
                If Len(Key) > 0 Then
                    .Item(Key) = Empty
                End If
            End If
        Next c
        If .Count = 0 Then Exit Function
        
        ArrUniqueRow = .Keys
    
    End With

End Function

推荐阅读