Code:
' Using the Index way for the tranposing
Sub Pretty3d() '
Rem 0 worksheets info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item("Sheet1")
Dim M As Long: Let M = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim arrTemp() As Variant
Rem To get the results in column T ( same as Yassers or Hans Results
' Ths first forumula gives me all the matches for F in the C ( helper column ) or error for no match
Let arrTemp() = Evaluate("=If({1},MATCH(F2:F" & M & ",Int(B2:B" & M & "),0))") ' If({1},____) may not be needed for Excel 2016 and higher The first formula does the main work
' The multiplication by $A$2:$A$1000=$I$1 limits the range used by effectively making 0 check dates outside or range of interest
Let arrTemp() = Evaluate("=IF({1},MATCH(F2:F" & M & ",Int(B2:B" & M & ")*($A$2:$A$1000=$I$1),0))") ' $A$2:$A$1000=$I$1 gives us an array full of Falses and Trues , which Excel will interpret mathematically as 0 or 1 This has the effect of giving us a 0 multiplyer on numbers outside our range of interst, so in total a 0 for outside our range of interest. Our range of interest gets a 1 multiplier so has therefore no change and we can find those numbers whereas we wont find a 0, well actually we will find a zero if the range to search for has a zero as it does further down, so we take care of that in the next line
' The above formula has one problem with the supplied data in that empty cells are seen in this formula as 0 which gives a match
Let arrTemp() = Evaluate("=IF(F2:F" & M & "=0,0,MATCH(F2:F" & M & ",C2:C" & M & "*(A2:A" & M & "=I1),0))") ' In looking in the range to find a match in ( the range to be searched we have all 0s outside the range caused by the previous $A$2:$A$1000=$I$1 So the first of these 0s will be seen as the match cell for all cells in F that are empty. So i take care here of the situation where an empty cell in F is by giving a 0 output So far two things retrn me a zero. You often find in formula building that the coercing If({1},___) suddenly is not needed. Her we find that the newly used here IF(F2:F463=0,0,___) is doing the required co oecing
' we will now do a simple If(ISERROR( ) , Row( ) , 0 ) on the above . This will give us a row indicie for the missing data, and a 0 for the found data
Let arrTemp() = Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")
' At this point we have wanted data or zeros. I want to conveniently use some VB string fuction whuch annoyingly onl work on 1 D arrays, so we convert it by a transpose in the next code line
Let arrTemp() = Application.Index(arrTemp(), Evaluate("=column(A:" & CL(M - 1) & ")"), Evaluate("=column(A:" & CL(M - 1) & ")/column(A:" & CL(M - 1) & ")"))
' Or
' Let arrTemp() = Application.Transpose(arrTemp())
Let arrTemp() = Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)"), Evaluate("=column(A:" & CL(M - 1) & ")"), Evaluate("=column(A:" & CL(M - 1) & ")/column(A:" & CL(M - 1) & ")"))
' The next few lines get rid of the 0s ( 2 lines commented out to prevent the shortened line messing up )
Dim StrTemp As String: Let StrTemp = "#" & Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data. The extra # allows us to remove all 0 entries via removing all #0 Without this we might get one left at the start
' Let StrTemp = Replace(StrTemp, "#0", "", 1, -1, vbBinaryCompare) ' This effectiveely removes the 0s data ( and its seperator )
' Let StrTemp = Mid(StrTemp, 2) ' Because I omit the third optional ( length ) argument I get all the remaing string after the first one. This effectively takes off the extra # which I don't need
Dim arrStrTemp() As String: Let arrStrTemp() = Split(StrTemp, "#", -1, vbBinaryCompare) ' remake the array
' Or ,
Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)"), Evaluate("=column(A:" & CL(M - 1) & ")"), Evaluate("=column(A:" & CL(M - 1) & ")/column(A:" & CL(M - 1) & ")")), "#"), "#0", ""), 2), "#")
' We need a "vertical" array for output, so we transpose
Let arrTemp() = Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")"))
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), arrTemp(), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
' Or
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
' or
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd" ' from macro recorder .NumberFormat = "[$-1010000]yyyy/mm/dd,@"
Stop
' Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
End Sub
Sub ShortPretty3d()
Dim M As Long: Let M = Worksheets("Sheet1").Range("A" & Worksheets("Sheet1").Rows.Count & "").End(xlUp).Row
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)"), Evaluate("=column(A:" & CL(M - 1) & ")"), Evaluate("=column(A:" & CL(M - 1) & ")/column(A:" & CL(M - 1) & ")")), "#"), "#0", ""), 2), "#")
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
End Sub
Function ShortPretty3dFunction(ByVal Nme As String) As Variant
Dim M As Long: Let M = Worksheets("Sheet1").Range("A" & Worksheets("Sheet1").Rows.Count & "").End(xlUp).Row
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=" & """" & Nme & """" & "),0)*(A2:A" & M & "=" & """" & Nme & """" & ")),ROW(F2:F" & M & "),0)"), Evaluate("=column(A:" & CL(M - 1) & ")"), Evaluate("=column(A:" & CL(M - 1) & ")/column(A:" & CL(M - 1) & ")")), "#"), "#0", ""), 2), "#")
Let ShortPretty3dFunction = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
End Function
Sub TestShortPretty3dFunction()
Dim arrTemp() As Variant
Let arrTemp() = ShortPretty3dFunction("aa")
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd"
End Sub
Reply With Quote
Bookmarks