HELP ON ARRAY CUSTOM FUNCTION NEEDED

C

CSTUBBS

New Member
Joined
Feb 13, 2007
Messages
45
I need to list out all unique values in cells A2,A3,andA4. Currently using a sort concatenate function found in --VBA and Macros for Excel that can probably be modified. Below is the SortConcat code, and a condensed version of the sheet.I need to modify the code so that it:
1)skips zeros
2)skips dates
3) will handle a single row,horizontal array 164 columns wide
4) sort in ascending order with numbers contained in parenthesis at the end
This spreadsheet will get approximately 30 rows of data a week. The formula will eventually be put in A1 and all data is copied/paste special values only to the next row, so all formulas are only in row 1.(TMI)
Code: 
Option Explicit

Function SortConcat(Rng As Range) As Variant
    'Rng —The range of data to be sorted and concatenated.
    Dim MySum As String, arr1() As String
    Dim j As Integer, i As Integer
    Dim cl As Range
    Dim concat As Variant
    On Error GoTo FuncFail:
    'initialize output
    SortConcat = 0#
    'avoid user issues
    If Rng.Count = 0 Then Exit Function
    'get range into variant variable holding array
    ReDim arr1(1 To Rng.Count)
    'fill array
    i = 1
    For Each cl In Rng
        arr1(i) = cl.Value
        i = i + 1
    Next
    'sort array elements
    Call BubbleSort(arr1)
    'create string from array elements
    For j = UBound(arr1) To 1 Step -1
        If Not IsEmpty(arr1(j)) Then
            MySum = arr1(j) & "," & MySum
        End If
    Next j
    'assign value to function
    SortConcat = Left(MySum, Len(MySum) - 1)
    'exit point
concat_exit:
    Exit Function
    'display error in cell
FuncFail:
    SortConcat = Err.Number & "-" & Err.Description
    Resume concat_exit
End Function

Sub BubbleSort(List() As String)
' Sorts the List array in ascending order
    Dim First As Integer, Last As Integer
    Dim i As Integer, j As Integer
    Dim Temp
    
    First = LBound(List)
    Last = UBound(List)
    For i = First To Last - 1
        For j = i + 1 To Last
            If UCase(List(i)) > UCase(List(j)) Then
                Temp = List(j)
                List(j) = List(i)
                List(i) = Temp
            End If
        Next j
    Next i
End Sub

Sheet
test for demension macro.xls
ABCDEFGHIJKLMNOPQRSTUVWXYZ
1currentoutputneededoutput111DATE112DATE113DATE114DATE121DATE122DATE123DATE124DATE131DATE132DATE133DATE134DATE
2(6/6),(6/8),0,0,0,12:00:00AM,12:00:00AM,12:00:00AM,4/16/2007,4/17/2007,4/19/2007,4/19/2007,4/19/2007,4/19/2007,4/20/2007,4/20/2007,4/20/2007,6,6,6,6,6,6,86,8,(6/6),(6/8)84/1764/1964/2001/064/16(6/8)4/19(6/6)4/2001/064/2064/1964/1901/0
310,10,10,10,12,12,12,12,12,12,12,12,4/19/2007,4/20/2007,4/20/2007,4/20/2007,4/20/2007,4/20/2007,4/20/2007,4/20/2007,4/20/2007,4/20/2007,4/20/2007,4/20/200710,12104/20104/20104/20104/20124/20124/20124/20124/19124/20124/20124/20124/20
44,4,4,4,4,4,4,4,4,4,4,4,4/10/2007,4/17/2007,4/18/2007,4/18/2007,4/18/2007,4/18/2007,4/19/2007,4/19/2007,4/19/2007,4/20/2007,4/20/2007,4/9/2007444/2044/1844/944/1944/1944/1944/1844/1744/1844/1844/2044/10
5
6
7
Sheet1
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Sort by date Sort by votes
Hi

How about something like this:

Code: 
Function NewSortConcat(Rng As Range) As String
    'Rng —The range of data to be sorted and concatenated.
    Dim MySum As String, arr1() As String
    Dim j As Integer, i As Integer
    Dim cl As Range
    On Error GoTo newFuncFail:
    'avoid user issues
    If Rng.Count = 0 Then Exit Function
    'get range into variant variable holding array
    ReDim arr1(1 To Rng.Count)
    'fill array
    i = 1
    For Each cl In Rng
        If Len(cl.Value) > 0 And (Not IsDate(cl.Value)) Then
            arr1(i) = cl.Value
            i = i + 1
        End If
    Next
    'sort array elements
    Call NewSort(arr1)
    'create string from array elements
    For j = UBound(arr1) To 1 Step -1
        If Not IsEmpty(arr1(j)) And arr1(j) <> "0" Then
            If j < UBound(arr1) Then
                If arr1(j) <> arr1(j + 1) Then
                    MySum = arr1(j) & "," & MySum
                End If
            Else
                MySum = arr1(j)
            End If
        End If
    Next j
    'assign value to function
    If Right$(MySum, 1) = "," Then
        MySum = Left$(MySum, Len(MySum) - 1)
    End If
    If Left$(MySum, 1) = "," Then
        MySum = Right$(MySum, Len(MySum) - 1)
    End If
    If Len(MySum) > 0 Then
        NewSortConcat = MySum
    Else
        NewSortConcat = "n/a"
    End If
    'exit point
newconcat_exit:
    Exit Function
    'display error in cell
newFuncFail:
    NewSortConcat = "Error#" & Err.Number & "-" & Err.Description
    Resume newconcat_exit
End Function

Sub NewSort(List() As String)
' Sorts the List array in ascending order
    Dim First As Integer, Last As Integer
    Dim i As Integer, j As Integer
    Dim Temp As String
   
    First = LBound(List)
    Last = UBound(List)
    For i = First To Last - 1
        For j = i + 1 To Last
            If Left$(List(i), 1) = "(" And Left$(List(j), 1) <> "(" Then
                'promote values over brackets
                Temp = List(j)
                List(j) = List(i)
                List(i) = Temp
            ElseIf Left$(List(i), 1) <> "(" And Left$(List(j), 1) = "(" Then
                'ignore
                DoEvents
            Else
                If UCase(List(i)) > UCase(List(j)) Then
                    Temp = List(j)
                    List(j) = List(i)
                    List(i) = Temp
                End If
            End If
        Next j
    Next i
End Sub

HTH, Andrew
 
Upvote 0
Code: 
Function cstubbs(rng As Range) As String
Dim a(), i As Long, r As Range, n As Long, dic As Object, m As Object
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
ReDim a(1 To rng.Count, 1 To 2)
With CreateObject("VBScript.RegExp")
     For Each r In rng
          If r.Value <> 0 And Not IsDate(r.Value) And Not dic.exists(r.Value) Then
               n = n + 1
               a(n,1) = r.Value
               .Pattern = "\D"
               .Global = True
               a(n,2) = .replace(r.Value, Chr(32))
               dic.add r.Value, Nothing
          End If
     Next
End With
VSortMA a, 1, n, 2
For i = 1 To n : cstubbs = cstubbs & "," & a(i,1) : Next
cstubbs = Mid$(cstubbs,2)
End Function

Private Sub VSortMA(ary, LB, UB, ref)
Dim M As Variant, i As Long, ii As Long, iii As Long, temp
i = UB : ii = LB
M = ary(Int((LB + UB) / 2), ref)
Do While ii <= i
     Do While ary(ii,ref) < M
          ii = ii + 1
     Loop
     Do While ary(i, ref) > M
          i = i - 1
     Loop
     If ii <= i Then
          For iii = LBound(ary,2) To UBound(ary,2)
               temp = ary(ii,iii) : ary(ii,iii) = ary(i,iii) : ary(i,iii) = temp
          Next
          i = i - 1 : ii = ii + 1
     End If
Loop
If LB < i Then VSortMA ary, LB, i, ref
If ii < UB Then VSortMA ary, ii, UB, ref
End Sub

Edited : code
 
Upvote 0
Thanks for the help Andrew, and yes Norie, it is the same thread. The first function(NewSortConcat) works fairly well, with one kink....

10,12,6,(10/10),(6/6),(HG12),(HG8) [actual output]
10,12,4,6,8 [actual output]

Seems the output sorts 2 digit numbers, then 1 digit numbers. Out of over 100 lines, these were the only two that had the sort problem. Would be great to get them sorted correctly, but the function serves its purpose satisfactorily. The actual order of the numbers in parenthesis is really not relevant, and always being at the end is nice.

The second function (cstubbs)gives me a #value! output.

Thanks for the help and interest.
 
Upvote 0
Hi

What you are seeing is VBA attempting to sort text values - Jindon's code is splitting the actual value from the way it is sorted. This would be the better approach but unfortunately I too get the #VALUE error. Jindon - have you enabled some sort of reference in your project?

If you want to tweak my code then change the sort routine to this:

Code: 
Sub NewSort(List() As String)
' Sorts the List array in ascending order
    Dim First As Integer, Last As Integer
    Dim i As Integer, j As Integer
    Dim temp As String
   
    First = LBound(List)
    Last = UBound(List)
    For i = First To Last - 1
        For j = i + 1 To Last
            If Left$(List(i), 1) = "(" And Left$(List(j), 1) <> "(" Then
                'promote values over brackets
                temp = List(j)
                List(j) = List(i)
                List(i) = temp
            ElseIf Left$(List(i), 1) <> "(" And Left$(List(j), 1) = "(" Then
                'ignore
                DoEvents
            Else
                If IsNumeric(List(i)) And IsNumeric(List(j)) Then
                    If Val(List(i)) > Val(List(j)) Then
                        temp = List(j)
                        List(j) = List(i)
                        List(i) = temp
                    End If
                Else
                    If UCase(List(i)) > UCase(List(j)) Then
                        temp = List(j)
                        List(j) = List(i)
                        List(i) = temp
                    End If
                End If
            End If
        Next j
    Next i
End Sub

This will put (10/10) in front of (6/6) because 1 is less than 6.....but it will put the values not in brackets into the correct sequence.

Andrew

P.S. We could code the sort order for the bracketed values, but in what order would you expect the following values?
10/10, 6/6, 4/6, 8/10, 1/10 2/5, 5/20, HG8 & HG12?
 
Upvote 0
Hi, Andrew

Isn't it still working?

P.S

Thanks Andrew and this time should be OK, I hope...
 
Upvote 0
Thanks very much Andrew and jindin. The new sort code modifications corrected the minor problem.
Code: 
P.S. We could code the sort order for the bracketed values, but in what order would you expect the following values? 
10/10, 6/6, 4/6, 8/10, 1/10 2/5, 5/20, HG8 & HG12?
[code]
Its not a big issue, but(a/b) would be better if all the a's were together and ascending, with the b's increasing in ascending order.The HG"c" should be at the end and "c" increasing in ascending order.Example:

(4/4),(4/8),(6/4),(6/10),(10/6),(10/12),(HG8),(HG12)

One additional note, There are some rare examples of (HG12HP). The 5th and 6th digits can only be "HP". The (XXXXHP) should be at the end .
example:
(4/4),(4/8),(6/4),(6/10),(10/6),(10/12),(HG8),(HG8HP),(HG12),(HG12HP)

Again, thanks for the help, and these are now very minor problems for the sheet.
 
Upvote 0
Hi

Try this:

Replace this part of the main function:
Code: 
    'sort array elements
    Call NewSort(arr1)
with this:
Code: 
    'sort array elements
    Call MyNewSort1(arr1)
    Call MyNewSort2(arr1)

And add the following new parts to your existing module:

Code: 
Sub MyNewSort1(List() As String)
'sorts numerical values only

Dim LoopLimit As Long, tempItem As String
Dim OuterLoop As Long, InnerLoop As Long

LoopLimit = UBound(List)

For OuterLoop = 2 To LoopLimit
    For InnerLoop = OuterLoop To 2 Step -1
        If Not IsNumeric(List(InnerLoop)) Then
            'ignore non-numerical values
            Exit For
        Else
            If Not IsNumeric(List(InnerLoop - 1)) Then
                'promote values over non-numerical values
                tempItem = List(InnerLoop)
                List(InnerLoop) = List(InnerLoop - 1)
                List(InnerLoop - 1) = tempItem
            Else
                'both are numeric
                If Val(List(InnerLoop)) < Val(List(InnerLoop - 1)) Then
                    tempItem = List(InnerLoop)
                    List(InnerLoop) = List(InnerLoop - 1)
                    List(InnerLoop - 1) = tempItem
                Else
                    Exit For
                End If
            End If
        End If
    Next
Next

End Sub


Sub MyNewSort2(List() As String)
'sorts text values only
'numerators grouped together, then denominators, then text values

Dim LoopLimit As Long, tempItem As String
Dim OuterLoop As Long, InnerLoop As Long
Dim numDiff As Long, denDiff As Long

LoopLimit = UBound(List)

For OuterLoop = 2 To LoopLimit
    For InnerLoop = OuterLoop To 2 Step -1
        If IsNumeric(List(InnerLoop - 1)) Then
            'the list has already been pre-sorted so ignore all
            '  numerical values below the current loop value
            Exit For
        Else
            If InStr(1, List(InnerLoop - 1), "/", 0) > 0 Then
            'fraction
                If InStr(1, List(InnerLoop), "/", 0) = 0 Then
                    'text values come after fractions
                    Exit For
                Else
                    '2 fractions - calculate the numerator difference
                    numDiff = Val(Mid$(List(InnerLoop - 1), 2, _
                                InStr(1, List(InnerLoop - 1), "/", 0) - 1)) _
                            - Val(Mid$(List(InnerLoop), 2, _
                                InStr(1, List(InnerLoop), "/", 0) - 1))
                    Select Case numDiff
                        Case Is > 0
                            tempItem = List(InnerLoop)
                            List(InnerLoop) = List(InnerLoop - 1)
                            List(InnerLoop - 1) = tempItem
                        Case Is = 0
                            'numerators the same - now check the denominator
                            denDiff = Val(Mid$(List(InnerLoop - 1), _
                                            InStr(1, List(InnerLoop - 1), "/", 0) + 1, _
                                            Len(List(InnerLoop - 1)) - _
                                                InStr(1, List(InnerLoop - 1), "/", 0) - 1)) - _
                                        Val(Mid$(List(InnerLoop), _
                                            InStr(1, List(InnerLoop), "/", 0) + 1, _
                                            Len(List(InnerLoop)) - _
                                                InStr(1, List(InnerLoop), "/", 0) - 1))
                            If denDiff > 0 Then
                                tempItem = List(InnerLoop)
                                List(InnerLoop) = List(InnerLoop - 1)
                                List(InnerLoop - 1) = tempItem
                            Else
                                Exit For
                            End If
                        Case Is < 0
                            Exit For
                    End Select
                End If
            Else
            'text
                If InStr(1, List(InnerLoop), "/", 0) > 0 Then
                    'text values come after fractions
                    tempItem = List(InnerLoop)
                    List(InnerLoop) = List(InnerLoop - 1)
                    List(InnerLoop - 1) = tempItem
                Else
                    '2 text values
                    numDiff = NumericalPortion(List(InnerLoop - 1)) - _
                                NumericalPortion(List(InnerLoop))
                    Select Case numDiff
                        Case Is > 0
                            tempItem = List(InnerLoop)
                            List(InnerLoop) = List(InnerLoop - 1)
                            List(InnerLoop - 1) = tempItem
                        Case Is = 0
                            If Len(List(InnerLoop)) > 0 And _
                                    (UCase(List(InnerLoop - 1)) > UCase(List(InnerLoop))) Then
                                tempItem = List(InnerLoop)
                                List(InnerLoop) = List(InnerLoop - 1)
                                List(InnerLoop - 1) = tempItem
                            Else
                                Exit For
                            End If
                        Case Is < 0
                            Exit For
                    End Select
                End If
            End If
        End If
    Next
Next

End Sub


Public Function NumericalPortion(InputStr As String) As Long

Dim Loop1 As Long, Loop2 As Long

For Loop1 = 1 To Len(InputStr)
    For Loop2 = Len(InputStr) To Loop1 Step -1
        If IsNumeric(Mid$(InputStr, Loop1, 1 + Loop2 - Loop1)) Then
            NumericalPortion = CLng(Mid$(InputStr, Loop1, 1 + Loop2 - Loop1))
            GoTo ExitNow
        End If
    Next
Next

NumericalPortion = 0

ExitNow:

End Function

I think this pretty does much what you want. It doesn't do a lot of error checking - it assumes the data is ok so it may cause problems if you enter data like this : (3/) instead of something like (3/4).

HTH, Andrew
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question Question
Function to return array of 10 largest absolute values while maintaining sign
Replies
3
Views
534
eurobonds
E
Ottsel
  • Solved
VBA: Custom Count and Search Function Help Needed
Replies
5
Views
501
Ottsel
Ottsel
Q
  • Question Question
VBA help I need to combine two codes
Replies
1
Views
648
Fluff
Fluff
C
  • Question Question
Issues subtotaling and breaking down the subtotal outline to obtain records for copying.
Replies
0
Views
569
Chris101
C
P
  • Question Question
ListBox Click to textbox & delete row
Replies
0
Views
592
pure vito
P

Forum statistics

Threads
1,223,227
Messages
6,170,848
Members
452,361
Latest member
d3ad3y3

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top