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

 

[NateO]

Right, event time.





Psst, delete combined with the Special Cells method always deletes the entire row.

 

[Greg Truby]

Psst, delete combined with the Special Cells method always deletes the entire row.

Kinda an import point there, boss . Suppose a feller had something he wanted to keep off to the right of the cells he's acting upon here.

 

[NateO]

1) Move it instead of deleting, similar to using a function.

2) Don't combine the two. E.g.,

<font face=Courier New><SPAN style="color:darkblue">Sub</SPAN> Tester2()
<SPAN style="color:darkblue">Dim</SPAN> myRng1 <SPAN style="color:darkblue">As</SPAN> Range, myRng2 <SPAN style="color:darkblue">As</SPAN> Range
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>
Sheets(3).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>
    <SPAN style="color:darkblue">Set</SPAN> myRng2 = Range([a1], [a65536].End(3)).SpecialCells(xlVisible)
    myRng2.Delete shift:=xlUp
    [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>

 

[monica S]

Ooops... one more question....

This is the way that I have the code (with the name of the function changed so that I don't get fired ):

Function udfSortDate(ByVal oldDates As Range, _
ByVal newDates As Range) As Variant

' Credit goes to Nate O., & Corticus. I just took
' their ideas from various threads and combined them.

Dim oldArr As Variant, newArr As Variant
Dim myCol As Collection, i As Long, j As Long
Dim Swap1 As Variant, Swap2 As Variant
Dim strFormat As String

Let oldArr = oldDates.Value
Let newArr = newDates.Value
Set myCol = New Collection

If Not IsArray(oldArr) Then
myCol.Add oldArr, CStr(oldArr)
Else
For i = LBound(oldArr, 1) To UBound(oldArr, 1)
On Error Resume Next
myCol.Add oldArr(i, 1), CStr(oldArr(i, 1))
On Error GoTo 0
Next
End If

If Not IsArray(newArr) Then
On Error Resume Next
myCol.Add newArr, CStr(newArr)
Else
For i = LBound(newArr, 1) To UBound(newArr, 1)
On Error Resume Next
myCol.Add newArr(i, 1), CStr(newArr(i, 1))
On Error GoTo 0
Next
End If

For i = 1 To myCol.Count - 1
For j = i + 1 To myCol.Count
If myCol(i) > myCol(j) Then
Swap1 = myCol(i)
Swap2 = myCol(j)
myCol.Add Swap1, before:=j
myCol.Add Swap2, before:=i
myCol.Remove i + 1
myCol.Remove j + 1
End If
Next j
Next i

strFormat = oldDates.Cells(1, 1).NumberFormat
ReDim newArr(0 To (oldDates.Count + newDates.Count - 1))
For i = 0 To myCol.Count - 1
newArr(i) = Format(myCol(i + 1), strFormat)
Next i
For i = myCol.Count To UBound(newArr)
newArr(i) = ""
Next i

Set myCol = Nothing
udfSortDate = Application.Transpose(newArr)
End Function


Problem:
---> The function, when copied down seven lines as an array formula in cells D2:D8, returns the dates as TEXT, I think. I have to use the following formula to convert the dates (as text) to numbers that represent the dates in Excel date-time code:

={DATEVALUE(udfSortDate(B2:B7,C2))}
={DATEVALUE(udfSortDate(B2:B7,C2))}
={DATEVALUE(udfSortDate(B2:B7,C2))}
={DATEVALUE(udfSortDate(B2:B7,C2))}
={DATEVALUE(udfSortDate(B2:B7,C2))}
={DATEVALUE(udfSortDate(B2:B7,C2))}
={DATEVALUE(udfSortDate(B2:B7,C2))}


Question: How do you make this conversion from a "text date" to a "number date" within the code?

Thanks again!
~ Monica

 

[NateO]

Lord have mercy! Monica, please, for your sake, say it isn't so.

Okay, what the heck, don't do the following:

newArr(i) = Format(myCol(i + 1), strFormat)

Use a long integer and format the cells.

E.g., MsgBox TypeName(Format(22, "##")) gives you what you don't want.

Wow! I can't believe you're still going use this. In all seriousness, this is a very bad way to approach this, I give it a 0 on a 1 to 10 scale.

Did you see my note on transposing an array. I guess it doesn't matter, this thing is still going to be slower than molases even if optimized relative to native functionality. The function was appropriately named.

 

[Legacy 21301]

Psst, delete combined with the Special Cells method always deletes the entire row.

Kinda an import point there, boss . Suppose a feller had something he wanted to keep off to the right of the cells he's acting upon here.

Rather than just accepting what NateO claims, why don't you try it?

(Note : Your question is applicable to all Excel users - not only lumberjacks.)

 

[NateO]

Rather than just accepting what NateO claims, why don't you try it?

Are you saying otherwise?

The work around is simple enough, see my response.

 

[Legacy 21301]

Rather than just accepting what NateO claims, why don't you try it?

Are you saying otherwise?

Yes.

 

[NateO]

Really?

You can get the following to leave cells in column G intact?

[a2:f65536].SpecialCells(xlVisible).Delete shift:=xlUp

I'm pretty sure this didn't work in '00 the last time I checked.

 

[Legacy 21301]

Works for me (2002).