VB code needed for sorting function - please help!

[monica S]

Hi,

This has been driving me crazy... hopefully someone out there can help.

If I have an ORIGINAL range of dates in cells A1:A5:

22-Apr-04
30-Apr-04
22-May-04
22-Aug-04
22-Sep-04

and a TARGET date of say 16-Jun-04 in cell B1.

I would like to have a FUNCTION that will 'read' the OriginalDates, take the TargetDate into account, and then just INCLUDE or INSERT the target date among this original range of dates. The function would return the new dates in ascending order (i.e. with dates closest to now coming first and dates furthest from now coming last). The function would have to be typed in as an ARRAY function (with the { } bracketing the formula and closing it using Ctrl+Shift+Enter) and would return 1 more row than what is passed through OriginalDates argument.

so, the function would have two arguments and go something like this:

{=IncludeDate(OriginalDates,TargetDate)}

or;

{=(A1:A5,B1)}

In our example, the function would return the following sorted set of dates (with the June 16, 2004 date included and SORTED among the original set of dates):

22-Apr-04
30-Apr-04
22-May-04
*16-Jun-04*
22-Aug-04
22-Sep-04

in cells C1:C6 as a NEW OUTPUT RANGE of dates.

In this case, we would copy our function down 6 rows (one more than the OriginalDates) and close it with the Ctrl+Shift+Enter to make it an ARRAY of 6 rows.

A MACRO WILL NOT HELP IN THIS CASE. ALSO, USING THE DATA --> SORTING FUNCTIONALITY WILL NOT HELP IN THIS CASE. TRUE, BOTH WILL WORK, BUT THIS PROJECT CALLS FOR A **FUNCTION** TO HANDLE THE TASK.

Any ideas on how to go about doing this?

Thank you very much!
~ Monica

 

[monica S]

Thanks guys! If I were to have the Dates in Cells J16:J25 (what is currently in Cells A2:A6) and the Intermediary Calculations (what is currently in Cells C2:C6) in Cells L6:L15, how would that change our Unique Dates formulas below (what is currently in cells B2:B6)?

Thank you,
~ Monica

 

[NateO]

This has to be a school project right? Otherwise the constraints are very confusing, and in my estimation inappropriate. Why would you turn your back to native functionality like sorting?

Pure udf? Create an array, stack a custom collection class passing the string equivalent of each element as the key. Using an error trap, you now have a collection of unique values. Sort the class, e.g., http://www.mrexcel.com/board2/viewtopic.php?t=50628

Now, pass an integer to pull back the specific item.

But, this is going to be far slower (I have to suspect) than using native functionality and it's not dynamic, you need to have a handle on how large your collection is. Whereas the following should perform better and is dynamic:

<font face=Courier New><SPAN style="color:darkblue">Private</SPAN> <SPAN style="color:darkblue">Sub</SPAN> Worksheet_Change(<SPAN style="color:darkblue">ByVal</SPAN> Target <SPAN style="color:darkblue">As</SPAN> Range)
<SPAN style="color:darkblue">Dim</SPAN> myRng <SPAN style="color:darkblue">As</SPAN> Range
<SPAN style="color:darkblue">If</SPAN> Intersect(Target(1, 1), Range("a1:a65536")) <SPAN style="color:darkblue">Is</SPAN> <SPAN style="color:darkblue">Nothing</SPAN> <SPAN style="color:darkblue">Then</SPAN> <SPAN style="color:darkblue">Exit</SPAN> <SPAN style="color:darkblue">Sub</SPAN>
Application.ScreenUpdating = <SPAN style="color:darkblue">False</SPAN>
Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range([a1], [a65536].End(3)).AdvancedFilter Action:=xlFilterInPlace, Unique:=<SPAN style="color:darkblue">True</SPAN>
<SPAN style="color:darkblue">Set</SPAN> myRng = Range([a1], [a65536].End(3)).SpecialCells(xlVisible)
<SPAN style="color:darkblue">On</SPAN> <SPAN style="color:darkblue">Error</SPAN> <SPAN style="color:darkblue">Resume</SPAN> <SPAN style="color:darkblue">Next</SPAN>
Me.ShowAllData
<SPAN style="color:darkblue">On</SPAN> <SPAN style="color:darkblue">Error</SPAN> <SPAN style="color:darkblue">GoTo</SPAN> 0
<SPAN style="color:darkblue">If</SPAN> <SPAN style="color:darkblue">Not</SPAN> <SPAN style="color:darkblue">CBool</SPAN>(Err.Number) <SPAN style="color:darkblue">Then</SPAN>
    Err.Clear
    Application.EnableEvents = <SPAN style="color:darkblue">False</SPAN>
    myRng.EntireRow.Hidden = <SPAN style="color:darkblue">True</SPAN>
    Range([a1], [a65536].End(3)).SpecialCells(xlVisible).Delete
    [a:a].EntireRow.Hidden = <SPAN style="color:darkblue">False</SPAN>
    Application.EnableEvents = <SPAN style="color:darkblue">True</SPAN>
<SPAN style="color:darkblue">End</SPAN> <SPAN style="color:darkblue">If</SPAN>
Application.ScreenUpdating = <SPAN style="color:darkblue">True</SPAN>
<SPAN style="color:darkblue">End</SPAN> <SPAN style="color:darkblue">Sub</SPAN></FONT>

And, it should be more maintainable for less experienced Excel users. Really, a win-win over your targeted approach. :wink:

 

[monica S]

Hi Nate,

Thanks for your code. No, it isn't a school project... it's something for work. How does your code work? Do I cut and paste it into a module?

Thanks,
Monica

 

[NateO]

Okay Monica, I was confused. You can do what you're talking about, as I described, and it's not a matrix function call.

In any case, place it in the worksheet class module. Right-click the tab, left-click view code. Paste the code in the now opened worksheet module.

How does it work?

1) Reviews the range of the entered date to make sure it's in column A. If so:
2) Sort the range
3) Filter for unique values, remember what it finds
4) Remove the filter, hide the uniques
5) Delete the residual, visible cells

Done.

 

[Yogi Anand]

Thank you. This brings up another question: What happens if the original values in cells A2:A6 are all unique values. C6 shows a #NUM! error. Any idea how to fix this?

Thanks again,
~Mon
....

Hi Monica:

I don't get a #NUM! error with all unique values in cells A2:A6 -- see the following illustration ...

Book1
	A	B	C	D
1	MonicaDates		UniqueDates	5
2	15-Apr-04		04/15/04	2
3	14-May-04		05/14/04	3
4	15-May-04		05/15/04	4
5	15-Jun-04		06/15/04	5
6	15-Jul-04		07/15/04	6
Sheet1 (5)

Please check whether you have applied the formulas correctly!

 

[Yogi Anand]

i don't get that error at all monica. do you have the same formulas:...(using Yogi's formulas)..
....
the only drawback to this, is that it doesn't sort like the UNIQUEVALUES will. you can sort, but it would take more than Yogi's two columns i believe.
....
hth

Hi Zack:

My formulation extracts the Unique Values as well as sorts them (in the posted example in ascending order) -- or did I really miss something here?

 

[Zack Barresse]

this is what i got Yogi...

Book4
	A	B	C	D
1	Dates	UniqueDates
2	15-Apr-04	15-Apr-04	2
3	17-May-04	17-May-04	3
4	15-May-04	15-May-04	4
5	15-Jun-04	15-Jun-04	5
6	15-Jul-04	15-Jul-04	6
Sheet4 (2)

when i was reading your formula, i thought it was sorting (ascending) also. can you see anything?

 

[monica S]

Hi Yogi,

Now, I can get the formulas to work , but they don't seem to sort. Am I missing something?

Thanks,
Monica

 

[monica S]

Nate,

Thank you for your explanation. I have cut and pasted your code into a class module. Then, I've populated cells A1:A5 with dates. What next? Do I have to attach the code to a macro button to get it to work? Or something else? I'm really not familiar with this type of code. How do I actually EXECUTE the code?

Thanks and sorry for the silly question,
~ Monica

 

[Aladin Akyurek]

Activate Tools|Macro|Visual Basic Editor.
Activate Insert|Module.
Copy the code below and paste it in the pane entitled "...(Code)".
Activate File|Close and Return Microsoft Excel.

The code to copy and paste:

Option Explicit

Function ArrayUnion(ParamArray Arg() As Variant) As Variant
    ' Code: Juan Pablo González
    ' Spec: Aladin Akyurek
    ' May 4, 2003
    ' Ref: http://makeashorterlink.com/?P20022174
    ' Mod: Nov 3, 2003, to reduce number of ReDim Preserve calls.
    Dim TempUnion() As Variant
    Dim i As Long, Itm As Variant, Ctr As Long
    ReDim TempUnion(1 To UBound(Arg) - LBound(Arg) + 1) As Variant
    For i = LBound(Arg) To UBound(Arg)
        Arg(i) = Arg(i)
        If IsArray(Arg(i)) Then
            For Each Itm In Arg(i)
                Ctr = Ctr + 1
                If Ctr > UBound(TempUnion) Then
                    ReDim Preserve TempUnion(1 To UBound(TempUnion) * 2) As Variant
                End If
                'ReDim Preserve TempUnion(1 To Ctr) As Variant
                TempUnion(Ctr) = Itm
            Next Itm
        Else
            Ctr = Ctr + 1
            If Ctr > UBound(TempUnion) Then
                ReDim Preserve TempUnion(1 To UBound(TempUnion) * 2) As Variant
            End If
            'ReDim Preserve TempUnion(1 To Ctr) As Variant
            TempUnion(Ctr) = Arg(i)
        End If
    Next i
    If Ctr< UBound(TempUnion) Then
        ReDim Preserve TempUnion(1 To Ctr) As Variant
    End If
    ArrayUnion = TempUnion
End Function

Lets say that A1:A5 on Sheet1 houses the dates and B1 the date to include in the sorted, uniquified result list.

Activate Insert|Name|Define.
Enter Seq as name in the Names in Workbook box.
Enter the following formula in the Refers to box:

=UNIQUEVALUES(ARRAYUNION(Sheet1!$A$1:$A$5,Sheet1!$B$1),1)

Click Add.

Enter SizeSeq as name in the Names in Workbook box.
Enter the following formula in the Refers to box:

=COUNT(Seq)

Click OK.

Now you can have the sorted, uniquified list say in column C...

Book1
	A	B	C	D
1	22-Apr-04	16-Jun-04	22-Apr-04
2	30-Apr-04		30-Apr-04
3	30-Apr-04		16-Jun-04
4	22-Aug-04		22-Aug-04
5	22-Sep-04		22-Sep-04
6
Sheet1

The formula in C1, which is copied down, is:

=IF(ROW()-ROW($C$1)+1<=SizeSeq,INDEX(Seq,ROW()-ROW($C$1)+1),"")