Split cell value and add to array

[Makelei]

Hi,
I am using 2003 and XP.

In active cell I need to do the following in Worksheet_Change(ByVal Target
As Range).

As person gives values it can be following:
"Value1; Value2; Value3; Value2; Value4; Value2; Value5"

I want to modify given value to format:
"Value1; Value2; Value3; Value4; Value5"

Values are delimited with ";" and amount varies. It means that all given
values can be listed ONLY once. I imagine that this would be best to do with
array. That is a part that I really should study more - any suggestion for
good source?

Thanks in advance
MakeLei

 

[Jacob Skaria]

One way to do this..Right click the sheet tab>view code and paste the below
code.

The applicable range is given as A1:A20.
1;5;5;2 will be converted to 1;2;5
Try and feedback

Private Sub Worksheet_Change(ByVal Target As Range)
Dim intTemp, intTemp1 As Integer, intTemp2 As Integer
Dim strData As String, arrData As Variant
If Not Application.Intersect(Target, Range("A1:A20")) Is Nothing Then
If Target.Count = 1 Then
strData = Target.Text
arrData = Split(strData, ";")
For intTemp1 = 0 To UBound(arrData)
For intTemp2 = intTemp1 To UBound(arrData)
If arrData(intTemp2) < arrData(intTemp1) Then
intTemp = arrData(intTemp2)
arrData(intTemp2) = arrData(intTemp1)
arrData(intTemp1) = intTemp
End If
Next
Next
intTemp = 0: strData = ""
For intTemp1 = 0 To UBound(arrData)
If arrData(intTemp1) <> intTemp Then
strData = strData & ";" & arrData(intTemp1)
intTemp = arrData(intTemp1)
End If
Next
Application.EnableEvents = False
Cells(Target.Row, Target.Column) = Mid(strData, 2)
Application.EnableEvents = True
End If
End If
End Sub

If this post helps click Yes

 

[Makelei]

Thanks Jacob,
This was just what I needed and I got it and fast - thanks!

BR
MakeLei

 

[KC]

An variation for your testing

Sub main()
Dim v1 As Variant
Dim v2 As Variant

v1 = Split(Cells(1, 1), ";")
v2 = v1(0)
For i = 1 To UBound(v1)
If InStr(v2, v1(i)) = 0 Then v2 = v2 & ";" & v1(i)
Next i
Debug.Print v2

End Sub

 

[r]

try ... the alternative soluction:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Excel.Range
Dim rngU As Excel.Range
Static SalvaLoop As Boolean

Set rng = [a1:a20] '<< change with your range
If SalvaLoop Then Exit Sub

On Error Resume Next
Set rngU = Intersect(Target, rng)
On Error GoTo 0

SalvaLoop = True
If TypeName(rngU) = "Range" Then
For Each rng In rngU
rng.Value = _
Join( _
BoobleSort( _
Split( _
No_Duple_RE(CStr(rng.Value)), ";")), ";")
Next
End If
SalvaLoop = False
End Sub


Function No_Duple_RE(Testo As String) As String
Dim RE As Object
Dim M, s As String

Set RE = CreateObject("VBScript.RegExp")

RE.Global = True
RE.IgnoreCase = True
RE.Pattern = "[^;]+"
For Each M In RE.Execute(Testo)
RE.Pattern = "\b" & M & "\b"
If RE.Test(s) = False Then
s = s & ";" & M
End If
Next
RE.Pattern = "^;"
No_Duple_RE = RE.Replace(s, "")
End Function

Function BoobleSort(ByRef ArrB As Variant)
Dim i As Long, a As Long, v
Dim arrA
arrA = ArrB
For i = 0 To UBound(arrA) - 1
For a = i To UBound(arrA)
If arrA(i) > arrA(a) Then
v = arrA(i)
arrA(i) = arrA(a)
arrA(a) = v
End If
Next
Next
BoobleSort = arrA
End Function

regards
r

Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html