时间戳

首页 > 解决方案 > 显示独特细胞的功能

excel - 显示独特细胞的功能

问题描述

VBA 函数，删除重复项并用逗号写入

我需要一个公式（函数），它有两个参数：1.range（将被选中）2.separator 重复项之间的字符。示例我在不同的单元格中有一些产品代码 0001、0015、0015、0015、0015、0015、0015、0015、0015、0020。我想使用公式获得 0001、0015、0020。

我写的是：

Function UNIQUE_NUMBER(RangeD As Range, SepCharacter As String)
Dim UNIQUE As String
On Error GoTo msg
For Each cell In RangeD
If Not IsEmpty(cell) Then
    If Cells(cell.Row, cell.Column) = "" Then Resume Next
    r = cell.Row
    C = cell.Column
    a_length = Len(a)
    a = a & SepCharacter & Cells(r, C)


        If WorksheetFunction.Search(Cells(r, C) & SepCharacter, a, a_length + 1) > 1 And Cells(r, C) <> "" Then
        a = WorksheetFunction.Substitute(a, Cells(r, C) & SepCharacter, "", 1)

        End If
End If

Next cell
SepCharacter2 = SepCharacter & SepCharacter
UNIQUE = Mid(a, Len(SepCharacter) + 1, Len(a))
UNIQUE_NUMBER = Replace(Replace(Replace(Replace(Replace(Replace(Replace(UNIQUE, SepCharacter2, ""), SepCharacter2, ""), SepCharacter2, ""), SepCharacter2, ""), SepCharacter2, ""), SepCharacter2, ""), SepCharacter2, "")
Exit Function
msg:
Resume Next
End Function

它有时可以正常工作（不知何故），但有时不能，你提供什么？

标签： excelvba

解决方案

问题解决了

Function UNIQUE_WELDER(RangeD As Range, sepChar As String)

'we will gather all unique values into VAL1
VAL1 = ""
For Each cell In RangeD

'if value is added into VAL1 we will not add again
'and using replace function for deleting spaces
qty = InStr(VAL1, Replace(Replace(Replace(Replace(Replace(Replace(cell, " ", ""), " ", ""), " ", ""), " ", ""), " ", ""), " ", ""))
If qty > 0 Then VAL1 = VAL1 Else VAL1 = Replace(VAL1 & sepChar & cell, sepChar & sepChar, sepChar)
Next cell
'deleting first symbol
VAL2 = Mid(VAL1, Len(sepChar) + 1, 1000)
UNIQUE_WELDER = VAL2
End Function

推荐阅读