Code:
Sub SingleLineWithTranspose()
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1)
End Sub
Code:
Sub Pretty3bbaaTranspose() '
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:F463,C2:C463,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:F463,C2:C463*($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:F463=0,0,MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1),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:F463,C2:C463*($A$2:$A$1000=$I$1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),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:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))
' Or
Let arrTemp() = Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))
' 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:F463,C2:C463*($A$2:$A$1000=$I$1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")
' We need a "vertical" array for output, so we transpose
Let arrTemp() = Application.Transpose(arrStrTemp())
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.Transpose(arrStrTemp()), 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.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1)
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 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 SingleLineWithTranspose()
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1)
End Sub
Reply With Quote
Bookmarks