Excel VBA – 连续消除重复

晚上好，

我已阅读以前的post，并找不到这个特定问题的答案。

我有一个Excel中的VBA脚本，返回值到A2，B2，C2然后运行一个循环，以填充数据到A3，B3，C3等

我需要做的是使用VBA消除行中的重复值，并只返回唯一值。 我正在使用“/”分隔。

它需要忽略任何空白单元格。

这个想法是在下一个循环之前计算结果。

理想情况下，我只想显示结果，而不必填写A1，B1，C1等

您的帮助表示赞赏。

'Conditions If Cells(rw, 24) = Cells(rw, 26) And Cells(rw, 24) = Cells(rw, 25) Then Cells(rw, 18) = "'" & Cells(rw, 24) If Cells(rw, 24) <> Cells(rw, 26) Then Cells(rw, 18) = Cells(rw, 24) & "/" & Cells(rw, 26) Cells(rw, 20) = Application.VLookup(Cells(rw, 18), Workbooks("CMF Export.xlsx").Sheets("Data").Columns("C:D"), 2, False) ' Vlookup function If Not aCell Is Nothing Then Cells(rw, 23 + i) = Right(aCell.Value, 7) End If 

Answer 1

尝试使用Collection来存储唯一值：

 Sub test() Dim col As Collection Dim r As Range, c As Range Dim res As String, lastrow As Long, el 'change sheet name to suit With ThisWorkbook.Worksheets("Sheet1") 'Find last non empty row in column A lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row 'add text format to column E .Range("E2:E" & lastrow).NumberFormat = "@" 'iterates through each row For Each r In .Range("A2:C" & lastrow).Rows 'initialize collection Set col = New Collection 'iterates through each cell in row For Each c In r.Cells 'next lines adds only unique values On Error Resume Next col.Add CStr(c.Value), CStr(c.Value) On Error GoTo 0 Next 'collect result res = "" For Each el In col res = res & el & "/" Next If res <> "" Then res = Left(res, Len(res) - 1) 'write result in column E .Range("E" & r.Row).Value = res 'adding VLOOKUP (follow up from comments) 'With .Range("F" & r.Row) 'adjust Sheet1!A1:C100 to suit your needs ' .Formula = "=VLOOKUP(" & res & ",Sheet1!A1:C100,3,0)" 'next line rewrites formula with formula result ' .Value = .Value 'End With Set col = Nothing Next End With End Sub 

结果：