Split a Cell : Need Help

[deven_deesha]

I have a row as follow .

COL B has a data seperated by Alt + Enter. There is a duplciate data.

If there is a duplicate data then i want to neglect it and consider only one.

ex. Consider the following example

SUIT/ADR is may times in COL B. This is a input File.

COL A COL B
1 Suit/ADR

Suit/ADR

Suit/ADR

Suit/ADR

Claim Folder

2 Claim Folder

Claim Mgmt


I want the output in new file as

1 SUIT/ADR

1 Claim Folder

2 Claim Folder

2 Claim Mgmt


I tried to write a macro using Split function. But I stucked. Can you please help me?


Thanks

Shriswaroop

 

[jindon]

OK
try this one and if it works, I will explain...

Sub test()
Dim a, x, i As Long, b(), n As Long, e, myNum, c, myTxt, ii As Integer
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
a = Range("a1",Range("a" & Rows.Count).End(xlUp)).Value
ReDim b(1 To Rows.Count, 1 To 1)
With CreateObject("VBScript.RegExp")
   For Each e In a
      .Pattern = "^\d+"
      If InStr(e,Chr(10))>0 Then
         If .test(e) then
            myNum = .execute(e)(0)
         Else
            myNum = Empty
         End If
         myTxt = .replace(e,"")
         .Pattern = "^\s+\n"
         .Global = True
         .MultiLine = True
         myTxt = .replace(myTxt,"")
         n = n + 1 : b(n,1) = myNum & myTxt
         x = Split(e,Chr(10))
         For ii = 1 To UBound(x)
            If Not dic.exists(x(ii)) Then
               n = n + 1
               b(n,1) = myNum & x(ii)
               dic.add x(ii), Nothing
            End If
         Next
      Else
         n = n + 1 : b(n,1) = e
      End If
      dic.removeall : myTxt = Empty : myNum = Empty
   Next
End With
Set dic = Nothing : Erase a
Range("c1").Resize(n).Value = b
End Sub

 

[deven_deesha]

Nope.

If Not dic.exists(x(ii)) Then

the above statment is working properly. But what happens if there are different values in cell then it is not giving the exact solution.

ex: we have below data. Now Suit/ADR is present second time so it will ignore the same but Claim is there so I should get a oputput in new cell as Suit/ADR;Claim

Suit/ADR

Suit/ADR

Claim

I am also trying to edit the macro but the values are getiing overridden.

If Not dic.exists(x(ii)) Then
n = n + 1

b(n, 1) = res & myNum & x(ii) & ";"
res = b(n, 1)
dic.Add x(ii), Nothing
m = n

End If


Range("Af" + CStr(i)).Value = res

But it is not working the way I want : (

Appreciate your help

Shriswaroop

 

[jindon]

Can you just change the line.

x = Split(e,Chr(10))

to

x = Split(myTxt,Chr(10))

 

[deven_deesha]

If I change
x = Split(e, Chr(10))

to

x = Split(myTxt, Chr(10))

For loop fails.

Ubound (x) is not working. It gives the value as 0.

 

[deven_deesha]

I made some changes and it works partially.

Sub test()
Dim a, x, i As Long, b(), n As Long, e, myNum, c, myTxt, ii As Integer
Static res
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
a = Range("a1", Range("a" & Rows.Count).End(xlUp)).Value
ReDim b(1 To Rows.Count, 1 To 1)
With CreateObject("VBScript.RegExp")
i = 1
For Each e In a
'' If i = 734 Then
'' MsgBox "hold"
'' End If
.Pattern = "^\d+"
If InStr(e, Chr(10)) > 0 Then
If .test(e) Then
myNum = .Execute(e)(0)
Else
myNum = Empty
End If
myTxt = .Replace(e, "")
.Pattern = "^\s+\n"
.Global = True
.MultiLine = True
myTxt = .Replace(myTxt, "")
n = n + 1: b(n, 1) = myNum & myTxt
x = Split(e, Chr(10))
For ii = 1 To UBound(x)
If Not dic.exists(x(ii)) Then
n = n + 1
b(n, 1) = x(ii) & ";"
res = b(n, 1)
dic.Add x(ii), Nothing
End If
Next
Else
n = n + 1: b(n, 1) = e
End If
dic.RemoveAll: myTxt = Empty: myNum = Empty

Range("Af" + CStr(i)).Value = res

i = i + 1
Next
End With
Set dic = Nothing: Erase a
'Range("c1").Resize.Value = b
End Sub


What I want is some times there is a data in one cell only as follow.

Suit/ADR

Suit/ADR

Claim

Claim

Now Suit/ADR is duplicate so It will come once using above code but then Claim is different so it should concatenate as

Suit/ADR;Claim

Like if there is a different Data then it should ignore duplicate and consider a single value and concatenate. It should be seperated by ";"

I think I am doing some thing wrong. can't get it.

Can you please look in to this.

Thanks a lott for ur help

Shriswaroop

 

[jindon]

How about?

Sub test()
Dim a, x, i As Long, b(), n As Long, e, myNum, c, myTxt, ii As Integer
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
a = Range("a1",Range("a" & Rows.Count).End(xlUp)).Value
ReDim b(1 To Rows.Count, 1 To 1)
With CreateObject("VBScript.RegExp")
   .Pattern = "^\d+"
   For Each e In a
      If InStr(e,Chr(10))>0 Then
         If .test(e) then
            myNum = .execute(e)(0)
         Else
            myNum = Empty
         End If
         myTxt = Trim(.replace(e,""))
         n = n + 1 : b(n,1) = myNum & myTxt
         x = Split(Replace(e,Chr(32),""),Chr(10))
         For ii = 1 To UBound(x)
            If If Not IsEmpty(x(ii)) And Not dic.exists(x(ii)) Then
               n = n + 1
               b(n,1) = myNum & x(ii)
               dic.add x(ii), Nothing
            End If
         Next
      Else
         n = n + 1 : b(n,1) = e
      End If
      dic.removeall : myTxt = Empty : myNum = Empty
   Next
End With
Set dic = Nothing : Erase a
Range("c1").Resize(n).Value = b
End Sub

 

[deven_deesha]

No . Can I have your personal mail id so that I can send you the excel sheet the way I want. and It will be clear to you. we are very near to the solution.

The below line is not correct.
we have to print within the for loop. as It is for each cell.
Range("c1").Resize.Value = b