VB code needed for sorting function - please help!

monica S · Apr 23, 2004

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

Greg Truby · Apr 30, 2004

Ponsy,

I needed to leave for a Cub Scout's meeting (it's hard to convince my lad of the virtue of punctuality when I'm not) so's I took Nate's word for it. But you are correct. For me as well this


Sub ImaSpecialDeleter()
 Dim r As Range
 Set r = [A1:A10]
 r.SpecialCells(xlCellTypeConstants, XlSpecialCellsValue.xlNumbers).Delete shift:=xlShiftUp
End Sub

only deletes out of column A, leaving the contents of column B intact. If XL2000 does indeed behave differently (I can't test this without pesterin' coworkers) its a point we should all keep in mind if we'd use this combination of methods in a macro that'd be run on XL2000.

Nate/Monica,

I tried editing the tail end of this (old name preserved, I'm sentimental) but it's not solving the problem. If you breakpoint at End Function and View Locals, newArr is an array of Variant/Date but somehow the Tranpose function forces Fubar2 to be Variant/String. Set the breakpoint before the last loop and view locals and you can see Swap1 switch from Variant/String to Variant/Date, but the change doesn't "stick".
This whole thing is even more puzzling because using the Transpose() function in worksheet cells directly on cells with dates does not result in conversion to string. Monica, if your use of DateValue is working, I'd say keep using that. Unless someone else around here can fix the code, I must hang my head in defeat.

Attempted solution (I recycled Swap1 since it was handy):
 ReDim newArr(0 To (oldDates.Count + newDates.Count - 1))
 For i = 0 To myCol.Count - 1
 newArr(i) = myCol(i + 1)
 Next i
 For i = myCol.Count To UBound(newArr)
 newArr(i) = 0
 Next i
 Set myCol = Nothing
 Fubar2 = Application.WorksheetFunction.Transpose(newArr)
 For Each Swap1 In Fubar2
 Swap1 = CDate(Swap1)
 Next Swap1

NateO · Apr 30, 2004

Ladies and Gentlemen,

I am pleased to announce that in spite of her preoccupation with lumberjacks, Ponsy Nob. has managed to stumble into something reasonable with respect to a semantic in this thread (while it has broader implications). My statement about Delete and Special Cells was too general. Here's the deal, take the following:

Sub tester()
[a1:a10].SpecialCells(xlVisible).Delete xlUp
End Sub

1) Works fine when cells are hidden normally, as they were in my improved process.

2) Does not work when the cells are visible due to filtering.

So, be on alert as to why your cells are visble. I over applied my findings.

Next.

Greg,

1) There is no reason to transpose the array, sometimes it is necessary, this is not one of those times. This is bollox expensive. Stack a 2d array, I have shown the preferred approach in a prior post to this thread.

2) Another loop?! Lord have mercy. How many loops can throw into this ugly process?

3) Transpose has nothing to do with the elements coming across as strings. E.g.,

Sub fubar3()
Dim i As Variant
Let i = [{1;2;3}]
Let i = WorksheetFunction.Transpose(i)
MsgBox TypeName(i(1))
End Sub

Also posted in a previous post to this thread, the culprit is your use of the the Format Function. See the help file.

Monica, please do not use the UDFs in this thread. I feel very guilty about this, as we all should. You have a UDF that performs very badly and to make matters worse, you neither understand the semantics of it nor know how to maintain it, a bad situation all around. At the very least, please pull my name from the comments, I want nothing to do with it. The name of the function, in all seriousness, should be the least of your worries.

Greg Truby · Apr 30, 2004

Monica,

Nate's chastising notwithstanding another loop

lookaway

will actually allow us to flip these back. Add a new Dim up top...

 Dim varTemp As Variant
 '...
 varTemp = Application.WorksheetFunction.Transpose(newArr)
 For i = LBound(varTemp) To UBound(varTemp)
 If varTemp(i, 1) <> "" Then varTemp(i, 1) = CDate(varTemp(i, 1))
 Next i
 Fubar2 = varTemp
<hr>
Nate:

Sub fubar4()
 Dim i As Variant
 Let i = Array(#1/1/2000#, #2/1/2000#, #3/1/2000#)
 MsgBox TypeName(i(1)) ' date
 Let i = WorksheetFunction.Transpose(i)
 MsgBox TypeName(i(1, 1)) ' string
End Sub

NateO · Apr 30, 2004

Greg, I'm trying to get people to focus on how nasty this sordid business is. Nice obviously wasn't working. So, I'll continue with the new theme of my postings.

Ugly. Still, you should:

1) Not be transposing. Please explain why are you doing this?
2) Using longs
3) Not be adding loops to a function which loops, then has a double loop, then another loop in your addendum to my example which should not be implemented here, and yet another loop on your most recent addendum.

Ignorance is bliss; otherwise, this numbs the brain.

Greg Truby · Apr 30, 2004

Nate,

Used the ruddy Transpose() because I'm still getting used to moving items back and forth from cells to arrays and vice-versa, especially via an array-entered UDF. The way Excel kicks this stuff to a 2-D array is taking me some getting-used to, but I am learning plenty in this one. So, yeah, I guess it's ignorance. But your chiding is not falling on deaf ears. I think this is at least moderately better. Does away with that last loop and with the Transpose by doing what you suggested - stacking directly into a 2-D array. The part that took me some trial and error while viewing locals was figuring out how to dimension the 2-D array so that it would return what Excel wanted to dump properly into the cells.



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

 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 varTemp As Variant

 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)
 On Error GoTo 0
 Else
 For i = LBound(newArr, 1) To UBound(newArr, 1)
 On Error Resume Next
 myCol.Add newArr(i, 1), CStr(newArr(i, 1))
 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
 ReDim newArr(1 To (oldDates.Count + newDates.Count), 1 To 1)
 For i = 1 To myCol.Count
 newArr(i, 1) = myCol(i)
 Next i
 For i = myCol.Count + 1 To UBound(newArr)
 newArr(i, 1) = ""
 Next i
 Set myCol = Nothing
 udfSortDate2 = newArr
End Function

NateO · Apr 30, 2004

While critical, I am trying to be constructive. Fair enough then.

Okay 2 more items, one a question, and the second is a minor tweak.

1) What is the purpose of:

 For i = myCol.Count + 1 To UBound(newArr)
 newArr(i, 1) = ""
 Next i

?

2) Select the udf -> hit your delete key. Now paste the following event procedure into your worksheet class module:

http://www.mrexcel.com/board2/viewtopic.php?t=86068&start=21

Greg Truby · Apr 30, 2004

Nate,

1. The reason for that little bit at the end was due to Monica's post where she was asking how to supress #N/A return values. I explained that while one can help this a little by adding the bit of code you cited to the function, if the output cell count exceeds the input cell count you'll still end up with #N/A's.

I did time this new one and stacking the array versus using Transpose() cut the execution time by about 10% (though it still follows the same nasty curve). I didn't use the high-resolution timer you posted here, but I will definitely use it when I need it in the future - thanks for that BTW.

You never did answer the question I posed in post #40 - would this knave of a UDF consume addresses as a square of the number of inputs?

2. "Minor tweak" - I like that.

NateO · Apr 30, 2004

#40 eh. Let's see. Me thinks it should be related to the number of calls. 10 inputs, 10 additions, all unique, 20, by 20 calls equals 400, so yes.

Also, when you report 22 seconds for 1000 cells, do you mean per call or in total for all calls? I did corrupt a workbook with the udf, but I didn't test it, knowing the result was going to be scary.

Greg Truby · Apr 30, 2004

For dropping that array formula into x number of cells. Column A & Column B loaded with random dates between 1/1/1970 & 12/31/1979 (generated w/ RandBetween() then pasted values over the top).

Sub TimeTest()
 Dim varStart As Variant, varEnd As Variant
 Dim rng As Range, intHalfRow As Integer
 Dim strHalfRow As String, strFormula As String
 Dim rngOut As Range

 For intRows = 100 To 1200 Step 100
 Set rng = [D1]
 rng.EntireColumn.Delete
 Set rng = [D1]
 Set rng = rng.Resize(intRows)
 intHalfRow = intRows / 2
 strHalfRow = Trim(Str(intHalfRow - 1))
 'strFormula = "=fubar2(RC[-3]:R[" & strHalfRow & "]C[-3],RC[-2]:R[" & strHalfRow & "]C[-2])"
 strFormula = "=udfsortdate2(RC[-3]:R[" & strHalfRow & "]C[-3],RC[-2]:R[" & strHalfRow & "]C[-2])"
 Application.StatusBar = intRows
 varStart = Now
 Application.ScreenUpdating = False
 rng.FormulaArray = strFormula
 varEnd = Now
 Application.ScreenUpdating = True
 [D1].EntireColumn.Delete
 Set rngOut = Sheet5.[A50000].End(xlUp).Offset(1)
 rngOut = varStart
 rngOut.Offset(, 1) = varEnd
 rngOut.Offset(, 2) = intRows
 rngOut.Offset(, 3).FormulaR1C1 = "=RC[-2]-RC[-3]"
 rngOut.Offset(, 3).NumberFormat = "hh:mm:ss"
 Debug.Print varStart, varEnd, DateDiff("s", varStart, varEnd)
 Next intRows

 Application.StatusBar = False
End Sub

Legacy 21301 · Apr 30, 2004

NateO said:
Ladies and Gentlemen,

I am pleased to announce that in spite of her preoccupation with lumberjacks, Ponsy Nob. has managed to stumble into something reasonable with respect to a semantic in this thread (while it has broader implications). My statement about Delete and Special Cells was too general. Here's the deal, take the following:

Sub tester()
[a1:a10].SpecialCells(xlVisible).Delete xlUp
End Sub

1) Works fine when cells are hidden normally, as they were in my improved process.

2) Does not work when the cells are visible due to filtering.

So, be on alert as to why your cells are visble. I over applied my findings.

To avoid possible confusion amongst the tree-felling community, but mainly to point out that you are wrong, this behaviour has nothing to do with SpecialCells - which is what you have been claiming and continue to claim.
(I think "mis-applied" would be a more accurate description than "over applied".)

When there are one or more rows hidden by a filter, it is only possible to delete entire row(s).
This is true whether via SpecialCells, a cell by cell loop, manually without VBA, or whatever.
This, of course, is entirely logical.

With an "active" filter in place, the filter needs to be removed (or set to ShowAll) before Delete/ShiftCells can be used (either manually or via VBA).

However, you did manage to stumble into offering a useful warning (although it was mis-applied) :-
In VBA, using Delete/Shift in a range containing an "active" filter will cause the entire row(s) to be deleted.

VB code needed for sorting function - please help!

monica S

New Member

Greg Truby

MrExcel MVP

Excel Facts

NateO

Legend

Greg Truby

MrExcel MVP

NateO

Legend

Greg Truby

MrExcel MVP

NateO

Legend

Greg Truby

MrExcel MVP

NateO

Legend

Greg Truby

MrExcel MVP

Legacy 21301

Guest

Similar threads

Forum statistics

Share this page

VB code needed for sorting function - please help!

New Member

MrExcel MVP

Excel Facts

Legend

MrExcel MVP

Legend

MrExcel MVP

Legend

MrExcel MVP

Legend

MrExcel MVP

Legacy 21301

Guest

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock