arrays - 将范围(有条件)中的唯一值组合到另一个范围中

Question

我需要将范围(有条件)中的唯一值组合到同一行的另一个范围中。
其实我前两天发过类似的问题Link所提供的答案在我提出上述问题时有效。
但后来，我遇到了一个新问题，我宁愿问一个新的问题，让它更清楚:
(1) 如果单独范围内的所有单元格(例如 [C7:C8])都为空值，
然后我上了那条线 mtch = Application.Match(arr(i, 3), arrDC, 0)

Run-time error '13':Type mismatch

我可以在该行之前使用 On Error Resume Next ，但我认为这不是处理该错误的正确方法。
(2) 如果某些单元格或所有单元格位于单独的范围内，例如 [B9:B10] 具有空值，
然后我在最终结果中得到空行(在组合值之上)。
这是 link对于提供的具有预期输出的示例。
预先感谢您的学习支持和帮助。

Sub CombineRangesOneColumn_v2()

   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
'_________________________________________

   Dim sh As Worksheet, lastR As Long, arr, arrDict, dict As Object
   Dim arrDB, arrDC, mtch, arrFin, i As Long, j As Long, k As Long
   
   Set sh = ActiveSheet
   lastR = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
   
   arr = sh.Range("A2:C" & lastR).Value2
   Set dict = CreateObject("Scripting.Dictionary")
   
   For i = 1 To UBound(arr)
        If Not dict.Exists(arr(i, 1)) Then
            dict.Add arr(i, 1), Array(arr(i, 2), arr(i, 3))   'Place the strings from columns "B" and "C"
        Else
            arrDict = dict(arr(i, 1))                         'extract the array from dict items (it cnnot be modified inside the item)
            arrDict(0) = arrDict(0) & "|" & arr(i, 2)         'place in the array first element the strings collected from B:B
            arrDC = Split(arrDict(1), vbLf)                   'try splitting the second array element (string(s) from C:C)
            If UBound(arrDC) = 0 Then                         'if only one element:
                If arrDC(0) <> arr(i, 3) Then
                   arrDict(1) = arrDict(1) & IIf(arr(i, 3) = "", "", vbLf & arr(i, 3)) 'add to it the value from C:C, separated by vbLf
                End If
            Else
                mtch = Application.Match(arr(i, 3), arrDC, 0) 'check unicity of the string from C:C
                If IsError(mtch) Then                         'only if not existing:
                    arrDict(1) = arrDict(1) & IIf(arr(i, 3) = "", "", vbLf & arr(i, 3))  'add it to the string to be used in the next step
                End If
            End If
            dict(arr(i, 1)) = arrDict                         'put back the array in the dictionary item
        End If
   Next i

   ReDim arrFin(1 To UBound(arr), 1 To 1): k = 1              'redim the final array and initialize k (used to fill the array)
   For i = 0 To dict.Count - 1                                'iterate between the dictionary keys/items:
        arrDict = dict.Items()(i)                             'place the item array in an array
        arrDB = Split(arrDict(0), "|")                        'obtain an array of B:B strins from the item first array element
        For j = 0 To UBound(arrDB)                            'how many unique keys exists 'place the dictionry key per each iteration
                arrFin(k, 1) = arrDB(j) & vbLf & arrDict(1)   'build the string of the second column
                k = k + 1
        Next j
   Next i
   'Drop the processed result near the existing range (for easy visual comparison):
   sh.Range("D2").Resize(UBound(arrFin), 1).Value2 = arrFin
'_______________________________________________
   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic
End Sub    

Answer 1

合并唯一值

Sub Extract_unique_values_and_combine_in_adjacent_cells()
    
    ' The delimiter between the 2nd column value and the 3rd column values.
    Const dDelimiter As String = vbLf ' use e.g. 'vbLf & vbLf' to understand
    ' The delimiter between the 3rd column values.
    Const vDelimiter As String = vbLf ' use e.g. ',' to understand
    
    ' Reference the worksheet ('ws').
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    ' Reference the table range (has headers).
    Dim strg As Range: Set strg = ws.Range("A1").CurrentRegion
    
    ' Calculate the number of data rows ('rCount')(exclude header row).
    Dim rCount As Long: rCount = strg.Rows.Count - 1
    
    ' Reference the source data range ('srg') (no headers).
    Dim srg As Range: Set srg = strg.Resize(rCount).Offset(1)
    
    ' Write the values from the source range to a 2D one-based array,
    ' the source array ('sData').
    Dim sData() As Variant: sData = srg.Value
    
    ' Reference a newly created dictionary object ('dict').
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case-insensitive i.e. 'a = A'
    
    ' The dictionary's 'keys' will hold the unique values from the 1st column,
    ' while each associated dictionary's 'item' will hold another dictionary
    ' whose 'keys' will hold the unique values from the 3rd column.
    
    Dim Key1 As Variant
    Dim Key3 As Variant
    Dim r As Long
    
    ' Loop through the rows of the source array...
    For r = 1 To rCount
        ' Write the current value from the 1st column to a variable ('Key1')...
        Key1 = sData(r, 1)
        ' ... and check if it isn't already a 'key' of the dictionary.
        If Not dict.Exists(Key1) Then ' not a 'key' in dictionary
            ' Add the value as the 'key' and assign a newly created dictionary
            ' to the associated item ('dict(Key1)').
            Set dict(Key1) = CreateObject("Scripting.Dictionary")
            dict(Key1).CompareMode = vbTextCompare ' case-insensitive
        'Else ' is a 'key' of the dictionary; do nothing
        End If
        ' Write the current value from the 3rd column to a variable ('Key3')...
        Key3 = sData(r, 3)
        If Not IsError(Key3) Then ' exclude errors
            If Len(CStr(Key3)) > 0 Then ' exclude blanks
                ' ... and add it to the 'keys' of the current 'item dictionary'.
                dict(Key1)(Key3) = Empty
            End If
        End If
    Next r
            
    ' Write the length of the 3rd column delimiter to a variable ('vLen')
    ' (to not calculate it over and over since it will be used in a loop).
    Dim vLen As Long: vLen = Len(vDelimiter)
    
    ' Concatenate the dictionary item dictionaries' keys to strings
    ' and replace the item dictionaries with those strings.
    
    Dim String3 As String
            
    ' Loop through the keys of the dictionary (dict.Keys)...
    For Each Key1 In dict.Keys
        ' Loop through the keys of the item dictionary ('dict(Key1).Keys')...
        For Each Key3 In dict(Key1).Keys
            ' ... and concatenate the values into a string ('String3').
            String3 = String3 & Key3 & vDelimiter
        Next Key3
        If Len(String3) > 0 Then ' the item dictionary was not empty
            ' Remove the redundant right most delimiter.
            String3 = Left(String3, Len(String3) - vLen)
        'Else ' the item dictionary was empty; do nothing
        End If
        ' Replace the item dictionary with the string.
        dict(Key1) = String3
        ' Reset the string variable.
        String3 = vbNullString
    Next Key1
            
    ' Define the the destination array ('dData'),
    ' a 2D one-based one-column string array with the same number of rows
    ' as the number of rows of the source array, .
    Dim dData() As String: ReDim dData(1 To rCount, 1 To 1)
            
    Dim String2 As String
            
    ' Loop through the rows of the source array...
    For r = 1 To rCount
        ' Write the 2nd column value, converted to a string, to a variable.
        String2 = CStr(sData(r, 2))
        ' Write the dictionary item associated to the key
        ' for the 1st column value to a variable.
        String3 = dict(sData(r, 1))
        If Len(String2) = 0 Then ' the 2nd column value is blank
            If Len(String3) > 0 Then ' the current string is not an empty string
                ' Write just the 3rd column (concatenated) strings.
                dData(r, 1) = String3
            'Else ' the current string is an empty string; do nothing
                ' Note that each element of the destination array is initially
                ' an empty string since it was declared 'As String'.
            End If
        Else ' the 2nd column value is not blank
            If Len(String3) > 0 Then ' the current string is not an empty string
                ' Concatenate the 2nd and 3rd column strings.
                dData(r, 1) = String2 & dDelimiter & String3
            Else ' the current string is an empty string
                ' Write just the 2nd column string.
                dData(r, 1) = String2
            End If
        End If
    Next r
    
    ' Write the values from the destination array to the 2nd column
    ' of the source data range (no headers).
    srg.Columns(2).Value = dData
    
    ' Clear the 3rd column of the source table range (has headers).
    strg.Columns(3).Clear

End Sub