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)).ClearConte nts
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

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.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

Hi Howard,

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

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

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.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

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

On Sunday, August 4, 2013 8:10:09 AM UTC-7, Claus Busch wrote:
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



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.

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

On Sunday, August 4, 2013 9:10:13 AM UTC-7, GS wrote:
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

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.
Does not return to B2 with ;'s but does sort properly into row 1.

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.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

On Sunday, August 4, 2013 9:21:07 AM UTC-7, Claus Busch wrote:
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.

Does not return to B2 with ;'s but does sort properly into row 1.



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.

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

On Sunday, August 4, 2013 3:22:11 PM UTC-7, GS wrote:
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


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

On Sunday, August 4, 2013 8:56:44 PM UTC-7, GS wrote:
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


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

On Sunday, August 4, 2013 9:47:48 PM UTC-7, Howard wrote:
On Sunday, August 4, 2013 8:56:44 PM UTC-7, GS wrote:

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





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




Regards,

Howard


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