在每一行中连接唯一的单元格值

Question

如何在每行中连接唯一的单元格值以适应下面的代码。删除单元格中的重复值。宏后的结果是第二张图像。

Sub Concatenar()

Dim myRange As Range
Dim c As Long
Dim r As Long
Dim txt As String
Set myRange = Application.InputBox("Selecione a primeira e a última célula:", Type:=8)
For r = 1 To myRange.Rows.Count
    For c = 1 To myRange.Columns.Count
        If myRange(r, c).Text <> "" Then
             txt = txt & myRange(r, c).Text & vbLf
        End If
    Next
      If Right(txt, 1) = vbLf Then
       txt = Left(txt, Len(txt) - 1)
    End If
    myRange(r, 1) = txt
    txt = ""
Next
Range(myRange(1, 2), myRange(1, myRange.Columns.Count)).EntireColumn.Delete
End Sub

Answer 1

我相信，这就是你想要的。它将值粘贴/转置到临时工作簿，使用RemoveDuplicates将其修剪下来，并Join将它们全部拼凑在一起。然后，它将munged值粘贴回原始工作簿的A列，并删除其他列。

由于此代码的破坏性，您必须在数据副本上对其进行测试：

Sub CrazyPaste()
Dim wsSource As Excel.Worksheet
Dim rngToConcat As Excel.Range
Dim wbTemp As Excel.Workbook
Dim wsPasted As Excel.Worksheet
Dim rngPasted As Excel.Range
Dim i As Long
Dim LastRow As Long
Dim Results() As String

Set wsSource = ActiveSheet
Set rngToConcat = wsSource.UsedRange
Set wbTemp = Workbooks.Add
Set wsPasted = wbTemp.Worksheets(1)
wsSource.UsedRange.Copy
wsPasted.Range("A1").PasteSpecial Transpose:=True
Set rngPasted = wsPasted.UsedRange
ReDim Results(1 To rngPasted.Columns.Count)
For i = 1 To rngPasted.Columns.Count
    If WorksheetFunction.CountA(rngPasted.Columns(i)) = 0 Then
        Results(i) = ""
    Else
        rngPasted.Columns(i).RemoveDuplicates Columns:=1, Header:=xlNo
        LastRow = Cells(wsPasted.Rows.Count, i).End(xlUp).Row
        Results(i) = Replace(Join(Application.Transpose(rngPasted.Columns(i).Resize(LastRow, 1)), vbCrLf), _
                             vbCrLf & vbCrLf, vbCrLf)
    End If
Next i
With wsSource
    .Range("A1").Resize(i - 1, 1) = Application.Transpose(Results)
    .Range(.Cells(1, 2), .Cells(1, .Columns.Count)).EntireColumn.Delete
    wbTemp.Close False
End With
End Sub

在我的有限测试中，唯一可能产生不需要的结果的情况是第一列中的单元格为空，但该行中还有其他数据。然后，生成的单元格将以空白开始。