After sort and concant, one too many semi-colon

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
 
C

Claus Busch

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.
 
C

Claus Busch

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.
 
G

GS

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
 
H

Howard

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
 
H

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
 
H

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
 
G

GS

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
 
G

GS

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
 
H

Howard

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
 
G

GS

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
 
G

GS

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
 
G

GS

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
 
H

Howard

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
 
H

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
 
G

GS

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
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Lousy routine to get the first available day of the month 2
Help in sorting data 2
Column is overwritten 4
Copying Data Down the Column But Only Based on What's in Column A 3
Sort and align 2 ranges 1
Macro not returning correct data 3
error trying to sort data 4
Sorting problem : "The sort reference is not valid..........." 3

Top