After sort and concant, one too many semi-colon

  • Thread starter Thread starter Howard
  • Start date Start date
H

Howard

This works fine except the I would prefer NOT to have the last ;

Takes this:

A;C;B;N;M;Z;V

And returns this:

A;B;C;M;N;V;Z;

A nasty little semi colon at the end.

Thanks,
Howard

Option Explicit

Sub Sort_And_Stuff()
Dim rngC As Range

Range("A2").TextToColumns Destination:=Range("B1"), _
DataType:=xlDelimited, Semicolon:=True
ActiveSheet.Range("B1", ActiveSheet.Range("B1").End(xlToRight)).Sort _
Key1:=Range("B1"), Order1:=xlAscending, Orientation:=xlLeftToRight

For Each rngC In ActiveSheet.Range("B1", ActiveSheet.Range("B1").End(xlToRight))
Range("B2") = IIf(Len(rngC) = 0, Range("B2"), Range("B2") & rngC.Text) & ";"
Next
MsgBox Len(Range("B2").Value)
ActiveSheet.Range("B1", ActiveSheet.Range("B1").End(xlToRight)).ClearContents
End Sub
 
Hi Howard,

Am Sun, 4 Aug 2013 08:01:16 -0700 (PDT) schrieb Howard:
For Each rngC In ActiveSheet.Range("B1", ActiveSheet.Range("B1").End(xlToRight))
Range("B2") = IIf(Len(rngC) = 0, Range("B2"), Range("B2") & rngC.Text) & ";"
Next
Click to expand...

change the lines above to:
For Each rngC In ActiveSheet.Range("B1", _
ActiveSheet.Range("B1").End(xlToRight))
myStr = IIf(Len(rngC) = 0, myStr, myStr & _
rngC.Text & ";")
Next


Regards
Claus B.
 
Hi Howard,

Am Sun, 4 Aug 2013 17:10:09 +0200 schrieb Claus Busch:

please test following code. I think it is a little bit quicker:

Sub Test()
Dim myStr As String
Dim varOut As Variant
Dim i As Integer
Dim j As Integer
Dim strTemp As String

myStr = [A2]
varOut = Split(myStr, ";")

For j = UBound(varOut) - 1 To LBound(varOut) Step -1
For i = LBound(varOut) To j
If varOut(i) > varOut(i + 1) Then
strTemp = varOut(i)
varOut(i) = varOut(i + 1)
varOut(i + 1) = strTemp
End If
Next i
Next j
[B2] = Join(varOut, ";")
End Sub


Regards
Claus B.
 
Here's how I'd be inclined to build your delimited string...

Sub Sort_And_Stuff2()
Dim rng As Range, rngData As Range, sText$

Range("A2").TextToColumns Destination:=Range("B1"), _
DataType:=xlDelimited, Semicolon:=True
Set rngData = _
ActiveSheet.Range("B1", ActiveSheet.Range("B1").End(xlToRight))

With rngData
.Sort Key1:=Range("B1"), _
Order1:=xlAscending, _
Orientation:=xlLeftToRight
For Each rng In .Cells
If Len(rng) > 0 Then sText = sText & ";" & rng.Text
Next
sText = Mid(sText, 2): Range("B2") = sText: MsgBox Len(sText)
.ClearContents
End With 'rngData
End Sub

...where the delimiter is in front of each string and the Mid() function
is used to remove it.

A more simple approach is to use an array and filter it for empty
elements...

Sub Sort_And_Stuff3()
Dim vData, n&
vData = Split([A2], ";")
For n = LBound(vData) To UBound(vData)
If vData(n) = Empty Then vData(n) = "~"
Next 'n
[B2] = Join(Filter(vData, "~", False), ";")
End Sub

--
Garry

Free uenet access at http://www.eternal-september.org
Classic VB Users Regroup
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
Hi Howard,



Am Sun, 4 Aug 2013 08:01:16 -0700 (PDT) schrieb Howard:








change the lines above to:

For Each rngC In ActiveSheet.Range("B1", _

ActiveSheet.Range("B1").End(xlToRight))

myStr = IIf(Len(rngC) = 0, myStr, myStr & _

rngC.Text & ";")

Next





Regards

Claus B.
Click to expand...

I made the change you said and added these two lines to my code.
Does not return to B2 with ;'s but does sort properly into row 1.

Dim myStr As String
myStr = [B2]


The other code you suggested as faster works just fine.

Thanks, Claus. I have a ways to go to understand the U & L Bound, etc. I'd like to get my code working and then keep both to maybe help understand the code you offered.

Howard
 
Here's how I'd be inclined to build your delimited string...



Sub Sort_And_Stuff2()

Dim rng As Range, rngData As Range, sText$



Range("A2").TextToColumns Destination:=Range("B1"), _

DataType:=xlDelimited, Semicolon:=True

Set rngData = _

ActiveSheet.Range("B1", ActiveSheet.Range("B1").End(xlToRight))



With rngData

.Sort Key1:=Range("B1"), _

Order1:=xlAscending, _

Orientation:=xlLeftToRight

For Each rng In .Cells

If Len(rng) > 0 Then sText = sText & ";" & rng.Text

Next

sText = Mid(sText, 2): Range("B2") = sText: MsgBox Len(sText)

.ClearContents

End With 'rngData

End Sub



..where the delimiter is in front of each string and the Mid() function

is used to remove it.



A more simple approach is to use an array and filter it for empty

elements...



Sub Sort_And_Stuff3()

Dim vData, n&

vData = Split([A2], ";")

For n = LBound(vData) To UBound(vData)

If vData(n) = Empty Then vData(n) = "~"

Next 'n

[B2] = Join(Filter(vData, "~", False), ";")

End Sub
Click to expand...

Thanks, Garry. Between you and Claus I really have my homework laid out for.

I'm not sue if I will ever get rid of my Dunce hat.

Regards,
Howard
 
Hi Howard,



Am Sun, 4 Aug 2013 09:12:48 -0700 (PDT) schrieb Howard:


I made the change you said and added these two lines to my code.
Click to expand...
Does not return to B2 with ;'s but does sort properly into row 1.
Click to expand...



I forgot one line to copy:



For Each rngC In ActiveSheet.Range("B1", _

ActiveSheet.Range("B1").End(xlToRight))

myStr = IIf(Len(rngC) = 0, myStr, myStr & _

rngC.Text & ";")

Next

[B2]=left(mystr,len(mystr)-1)





Regards

Claus B.
Click to expand...
Smack on. Thanks Claus.

Regards,
Howard
 
I'm not sue if I will ever get rid of my Dunce hat

Ha, ha! That applies to a lot of us (including me<g>)! I admire your
willingness to learn, though, because it reminds me of me! Makes
working with you a pleasure...

--
Garry

Free uenet access at http://www.eternal-september.org
Classic VB Users Regroup
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
Oh no.., I forgot to sort!

Sub Sort_And_Stuff4()
Dim vData, vSort(), n&
vData = Split([a2], ";")
For n = LBound(vData) To UBound(vData)
If vData(n) = Empty Then vData(n) = "~"
Next 'n
vData = Filter(vData, "~", False)
ShellSortAny vData, UBound(vData), False
[b2] = Join(vData, ";")
End Sub

Sub ShellSortAny(arr, numEls&, SortDesc As Boolean)
Dim lNdx&, lNdx2&, lItem1st&, lDist&, vValue

If VarType(arr) < vbArray Then Exit Sub '//if not an array

lItem1st = LBound(arr)
'Find the best vValue for lDist
Do: lDist = lDist * 3 + 1: Loop Until lDist > numEls

'Sort the array
Do
lDist = lDist \ 3
For lNdx = lDist + 1 To numEls
vValue = arr(lNdx): lNdx2 = lNdx
Do While (arr(lNdx2 - lDist) > vValue) Xor SortDesc
arr(lNdx2) = arr(lNdx2 - lDist): lNdx2 = lNdx2 - lDist
If lNdx2 <= lDist Then Exit Do
Loop
arr(lNdx2) = vValue
Next
Loop Until lDist = 1
End Sub 'ShellSortAny

--
Garry

Free uenet access at http://www.eternal-september.org
Classic VB Users Regroup
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
Oh no.., I forgot to sort!



Sub Sort_And_Stuff4()

Dim vData, vSort(), n&

vData = Split([a2], ";")

For n = LBound(vData) To UBound(vData)

If vData(n) = Empty Then vData(n) = "~"

Next 'n

vData = Filter(vData, "~", False)

ShellSortAny vData, UBound(vData), False

[b2] = Join(vData, ";")

End Sub



Sub ShellSortAny(arr, numEls&, SortDesc As Boolean)

Dim lNdx&, lNdx2&, lItem1st&, lDist&, vValue



If VarType(arr) < vbArray Then Exit Sub '//if not an array



lItem1st = LBound(arr)

'Find the best vValue for lDist

Do: lDist = lDist * 3 + 1: Loop Until lDist > numEls



'Sort the array

Do

lDist = lDist \ 3

For lNdx = lDist + 1 To numEls

vValue = arr(lNdx): lNdx2 = lNdx

Do While (arr(lNdx2 - lDist) > vValue) Xor SortDesc

arr(lNdx2) = arr(lNdx2 - lDist): lNdx2 = lNdx2 - lDist

If lNdx2 <= lDist Then Exit Do

Loop

arr(lNdx2) = vValue

Next

Loop Until lDist = 1

End Sub 'ShellSortAny
Click to expand...

And I missed that myself. I put all the codes to a separate button and then ran them Bingo, Bango, Bongo... And flat overlooked the no sort on yours.

Hmmmm? With the new version...
If I put the top row in A2, it returns the bottom...?
Misses that first digit, letter (or word.)

9;8;7;6;5;4;3;2;1
9;1;2;3;4;5;6;7;8

V;Z;X;W;Q;P;R;C;B;A
V;A;B;C;P;Q;R;W;X;Z

Howard
 
Very interesting! I ddn't notice because I used the following text
string...

a;s;d;f;g;;b;v;;c;x

...so there would be empty elements in the array. The sort proc is
'found VB code' and so I can't take credit for it, but I'll see what
can be done with it to correct this issue.

--
Garry

Free uenet access at http://www.eternal-september.org
Classic VB Users Regroup
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
Got something that seems to work correctly testing with your/my
strings...

Sub Sort_And_Join()
Dim vData, vSort(), n&
vData = Split([A2], ";")
For n = LBound(vData) To UBound(vData)
If vData(n) = Empty Then vData(n) = "~"
Next 'n
vData = Filter(vData, "~", False)
SortArray vData
[B2] = Join(vData, ";")
End Sub

Sub SortArray(TheArray)
Dim Temp As Variant, X&, bSorted As Boolean

Do While Not bSorted
bSorted = True
For X = 0 To UBound(TheArray) - 1
If TheArray(X) > TheArray(X + 1) Then
Temp = TheArray(X + 1): TheArray(X + 1) = TheArray(X)
TheArray(X) = Temp: bSorted = False
End If
Next X
Loop
End Sub

--
Garry

Free uenet access at http://www.eternal-september.org
Classic VB Users Regroup
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
Testing further, the following string...

q;w;e;r;t;y;u;i;o;p;a;s;d;f;g;h;j;k;l;z;x;c;v;b;n;m;9;8;7;6;5;4;3;2;1;0

...returns...

0;1;2;3;4;5;6;7;8;9;a;b;c;d;e;f;g;h;i;j;k;l;m;n;o;p;q;r;s;t;u;v;w;x;y;z

--
Garry

Free uenet access at http://www.eternal-september.org
Classic VB Users Regroup
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
Testing further, the following string...



q;w;e;r;t;y;u;i;o;p;a;s;d;f;g;h;j;k;l;z;x;c;v;b;n;m;9;8;7;6;5;4;3;2;1;0



..returns...



0;1;2;3;4;5;6;7;8;9;a;b;c;d;e;f;g;h;i;j;k;l;m;n;o;p;q;r;s;t;u;v;w;x;y;z
Click to expand...

Indeed! You drove a stake right through the heart on that code.

Works for me just fine.

Thanks for the tome and effort, Garry.

Regards,
Howard
 
Indeed! You drove a stake right through the heart on that code.



Works for me just fine.



q;w;e;r;t;y;u;i;o;p;a;s;d;f;g;h;j;k;l;z;x;c;v;b;n;m;9;8;7;6;5;4;3;2;1;0
Click to expand...
Regards,

Howard
Click to expand...


Thanks for the tome and effort, Garry.

Tome is a large book, I meant TIME.

Howard
 
Your welcome! Typically, I use a temp wks to use Excel's sort because I
haven't found any really simple sort algorithms that I can add to my
mStringFunctions.bas as a standard reusable proc. Maybe now I have
something worth its salt! Thanks for the 'push'!<g>

--
Garry

Free uenet access at http://www.eternal-september.org
Classic VB Users Regroup
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
Back
Top