Extract missing dates for each person

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Extract missing dates for each person

Post by YasserKhalil »

Hello everyone
I have a column of names in column A and the related dates in column B. And there is a checking dates list in column F.
What I am doing is to compare the name according to the cell (I1) and matching with two criteria (the name and the date)
I did that using formulas like that

Code: Select all

=IFERROR(INDEX($A$2:$C$1000,MATCH(1,($A$2:$A$1000=$I$1)*($C$2:$C$1000=F2),0),3),"Missing")
Then I manually filter by Missing and copied the results to Sheet2
How can this be done by code? The expected result is in sheet2
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 78235
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Extract missing dates for each person

Post by HansV »

Can we use the helper column C in the code or do you want to avoid that?
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Extract missing dates for each person

Post by YasserKhalil »

No problem with using helper columns but if it is possible to avoid it would be better certainly. Thanks a lot my tutor.

User avatar
HansV
Administrator
Posts: 78235
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Extract missing dates for each person

Post by HansV »

Try this. It doesn't use helper columns.

Code: Select all

Sub ListMissing()
    Dim wsh1 As Worksheet
    Dim wsh2 As Worksheet
    Dim rng1 As Variant
    Dim rng2 As Variant
    Dim m1 As Long
    Dim m2 As Long
    Dim r1 As Long
    Dim r2 As Long
    Dim r3 As Long
    Dim dct1 As Object
    Dim dct2 As Object
    Dim n As Variant
    
    Set dct1 = CreateObject("Scripting.Dictionary")
    Set wsh1 = Worksheets("Sheet1")
    m1 = wsh1.Range("A" & wsh1.Rows.Count).End(xlUp).Row
    rng1 = wsh1.Range("A2:B" & m1).Value
    For r1 = 1 To UBound(rng1)
        If Not dct1.Exists(rng1(r1, 1)) Then
           Set dct2 = CreateObject("Scripting.Dictionary")
            dct1.Add Key:=rng1(r1, 1), Item:=dct2
        End If
        dct1(rng1(r1, 1))(Int(rng1(r1, 2))) = 1
    Next r1
    
    m2 = wsh1.Range("F" & wsh1.Rows.Count).End(xlUp).Row
    rng2 = wsh1.Range("F2:F" & m2).Value
    
    Set wsh2 = Worksheets("Sheet2")
    wsh2.Range("2:" & wsh2.Rows.Count).Clear
    r3 = 1
    
    For Each n In dct1.Keys
        Set dct2 = dct1(n)
        For r2 = 1 To UBound(rng2)
            If Not dct2.Exists(rng2(r2, 1)) Then
                r3 = r3 + 1
                wsh2.Range("A" & r3).Value = n
                wsh2.Range("B" & r3).Value = rng2(r2, 1)
            End If
        Next r2
    Next n
End Sub
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Extract missing dates for each person

Post by YasserKhalil »

That's awesome. Thank you very much.

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Extract missing dates for each person

Post by Doc.AElstein »

Hi
I spent a bit of time looking at Hans macro for my own learning purposes, because I like that sort of dictionary way of doing things generally, and the dictionary in a dictionary / like an array of array things type idea also appeals to me…
Also the original formula was also quite interesting as well. While I was looking at that, I came up with a few similar formulas and in conjunction with Evaluate(“ “) Range thing that I like, I have done a few alternatives to do things similar to the original requirements of this Thread.

For example, this bit ………. using formulas like that
=IFERROR(INDEX($A$2:$C$1000,MATCH(1,($A$2:$A$1000=$I$1)*($C$2:$C$1000=F2),0),3),"Missing")
Then I manually filter by Missing and copied the results
…..
That can be done in a single code line, …. _
https://excelfox.com/forum/showthread.p ... #post15420
https://excelfox.com/forum/showthread.p ... #post15421
_..But its beauty is somewhat spoilt by the code window not being wide enough .
( If I use a Transpose function at one place instead of my preferred Index way of transposing things, then I can reduce it to a single code line: This for example will get your pasted results for the unique “aa” Missings

Code: Select all

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
)
Here are some of the full workings used to get that last single code line:
https://excelfox.com/forum/showthread.p ... #post15431

_._________________
If we sanitise my coding a bit we can get a basic formula in Evaluate(“ “) Range thing type solution and extend the idea a bit further to make a simple function which you feed the unique name to
https://excelfox.com/forum/showthread.p ... #post15429
_.___________________

Finally, If I use a simple Dictionary way to get your unique names from your column A, then I can incorporate my ideas into a full alternative solution that gets the same results as Hans using your uploaded test data.

Sub EvaluateRangeFormulaWay() ( in next post )
Rem 1 Gets your unique names from column A
Rem 2 Loops through those unique names and each time in the loop the Function is called to get an array of your missings.
Macro is here:.._
https://excelfox.com/forum/showthread.p ... #post15433
_.. and also in the next post and also in uploaded file

_.__________________________

It’s interesting perhaps for comparison reasons only. It shows how we can use the Evaluate(“ “) Range thing solution to turn a basic Excel spreadsheet formula solution idea into a VBA solution.
I expect probably in this case, though, I might prefer the dictionary code way..
But I thought it was worth sharing the attempt , just out of interest..

I am just adding the extra alternative solution idea here out of passing interest, that’s all.

Alan
You do not have the required permissions to view the files attached to this post.
Last edited by Doc.AElstein on 07 Mar 2021, 13:24, edited 2 times in total.
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Extract missing dates for each person

Post by Doc.AElstein »

Code: Select all

Sub EvaluateRangeFormulaWay()  '   http://www.eileenslounge.com/viewtopic.php?p=281315#p281315
Rem 0 worksheets info
Dim Ws1 As Worksheet, Ws2 As Worksheet
 Set Ws1 = ThisWorkbook.Worksheets.Item("Sheet1"): Set Ws2 = ThisWorkbook.Worksheets.Item("Sheet2Alan")
Dim Em1 As Long: Let Em1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim arrA1() As Variant: Let arrA1() = Ws1.Range("A1:A" & Em1 & "").Value2  '  All names list
Rem 1
Dim Dik1 As Object: Set Dik1 = CreateObject("Scripting.Dictionary")
' 1b) make list of unique names
Dim Cnt
    For Cnt = 2 To Em1 ' Looping down all names
     Let Dik1(arrA1(Cnt, 1)) = "This can be anything you like, it don't really matter. What happens here is that we try to put this text in the Item of a dictionary entry that has the key of  the value of    arrA1(Cnt, 1)       If that entry does not exist, then the dictionary is programmed not to error , but instead make ( Add )  an entry with that key value.    For our purposes we don't care what the items are.  But at the end of this loop we will have effectively  Added  a element in the dictionary, one for each of the unique name values.  We can then use the  Keys()  array as a convenient way to get an array of unique names"
    Next Cnt
Dim arrUnics() As Variant: Let arrUnics() = Dik1.Keys() ' This is an array of our  unique  Names
Rem 2 Do it
Dim R3Lne As Long: Let R3Lne = 2    ' This is the next free line in second worksheet
    For Cnt = 0 To UBound(arrUnics()) ' looping through all uniques names
    Dim arrMisins() As Variant: Let arrMisins() = Missings(arrUnics(Cnt))  '## Go to the function that makes an array of the  Missing  dates   based on the  Name value
    Dim NoMisins As Long: Let NoMisins = UBound(arrMisins(), 1)
     Let Ws2.Range("A" & R3Lne & ":A" & R3Lne + (NoMisins - 1) & "").Value = arrUnics(Cnt) ' Put the name in as many cells as we have  missing  dates
     Let Ws2.Range("B" & R3Lne & ":B" & R3Lne + (NoMisins - 1) & "").Value = arrMisins()   ' Put the missing dates in
     Let R3Lne = R3Lne + NoMisins  ' This is the next free line in second worksheet
    Next Cnt
 
 Let Ws2.Range("B2:B" & Ws2.UsedRange.Rows.Count + 1 & "").NumberFormat = "yyyy/mm/dd"
End Sub
Function Missings(ByVal Nme As String) As Variant
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Worksheets("Sheet1").Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=" & """" & Nme & """" & "),0)*($A$2:$A$1000=" & """" & Nme & """" & ")),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")
Dim arrTemp() As Variant: 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)
 Let Missings = arrTemp()
End Function








Sub TestFunctionMissings()
Dim arrTemp() As Variant
 Let arrTemp() = Missings("bb")
 ' Columns("T:T").ClearContents  ' 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
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Extract missing dates for each person

Post by YasserKhalil »

Thanks a lot Mr. Alan
Why did you use this part `Evaluate("=COLUMN(A:QT)")` why QT column exactly? And did you rely on helper columns in the main code and the Missing UDF to execute the main code?
I tested the code on the original file but the results are not as expected..
This is your code after I have tried to arrange it in a way that I can read and understand

Code: Select all

Sub EvaluateRangeFormulaWay()
    Dim a(), b(), c(), ws As Worksheet, sh As Worksheet, dic As Object, cnt As Long, m As Long, n As Long, x As Long
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set sh = ThisWorkbook.Worksheets("Sheet2")
    m = ws.Range("A" & ws.Rows.Count & "").End(xlUp).Row
    a() = ws.Range("A1:A" & m & "").Value2
    Set dic = CreateObject("Scripting.Dictionary")
    For cnt = 2 To m
        dic(a(cnt, 1)) = Empty
    Next cnt
    b() = dic.Keys()
    n = 2
    For cnt = 0 To UBound(b())
        c() = Missings(b(cnt))
        x = UBound(c(), 1)
        sh.Range("A" & n & ":A" & n + (x - 1) & "").Value = b(cnt)
        sh.Range("B" & n & ":B" & n + (x - 1) & "").Value = c()
        n = n + x
    Next cnt
    sh.Range("B2:B" & sh.UsedRange.Rows.Count + 1 & "").NumberFormat = "yyyy/mm/dd"
End Sub

Function Missings(ByVal sName As String) As Variant
    Dim a() As String, b()
    a() = Split(Mid(Replace("#" & Join(Application.Index(Worksheets("Sheet1").Evaluate("=IF(ISERROR(MATCH(F2:F1000,C2:C1000*($A$2:$A$1000=" & """" & sName & """" & "),0)*($A$2:$A$1000=" & """" & sName & """" & ")),ROW(F2:F1000),0)"), Evaluate("=COLUMN(A:QT)"), Evaluate("=COLUMN(A:QT)/COLUMN(A:QT)")), "#"), "#0", ""), 2), "#")
    b() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(a(), Evaluate("=ROW(1:" & UBound(a()) + 1 & ")/ROW(1:" & UBound(a()) + 1 & ")"), Evaluate("=ROW(1:" & UBound(a()) + 1 & ")")), 1)
    Missings = b()
End Function
The code works fine on the file you attached but when trying to adapt to the original file, the results are not as expected.

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Extract missing dates for each person

Post by Doc.AElstein »

Hi Yasser

_(i) Yes, I am using the helper column, Column C. But I just took a quick look, and it seems that a simple modification will let the macro work on column B rather than column C
So it can be modified I think to work without a helper column.

_(ii) Yes, it needs the UDF, Function Missings( )

_(iii) I tested the code on the original file and I get exactly the same results as with Hans macro

_(iv) COLUMN(A:QT) is used to get like 1, 2, 3, …… 462
That bit probably need to be changed to make the macro dynamic
( Just for passing info.....

Code: Select all

Sub CL462()
Dim Ltr As String
 Let Ltr = CL(462): Debug.Print Ltr
End Sub
Public Function CL(ByVal lclm As Long) As String '         http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
    Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function
)

_(v) The file I attached is your original file with just a few things that I added. But I have not changed your basic data. So I don’t know why you are having problems. As far as the test data is concerned, the files should be identical

If you want to give me a another file in which Hans macro is giving you the correct results, then I can take a look to see if there are any outstanding issues with my macro alternative. -
I expect I possibly need to adjust a few things to make it dynamic. ( While I am doing that I can change it to work on column B rather than the help column C )

Alan
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Extract missing dates for each person

Post by YasserKhalil »

Sorry for the question: What is part of the last code that I posted should I modify to avoid using the helper column column C?!

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Extract missing dates for each person

Post by Doc.AElstein »

I have not checked thoroughly yet, but I think this might work in my original macro
Change
C2:C463
to
Int(B2:B463)

I am not too sure about your version yet. I have not looked at that in detail yet.
I am not too sure yet why you use _1000
I expect that could cause issues
I expect the macro needs to have that number set dynamically somehow...

I will have another look at this, just out of interest, later, and perhaps post later another alternative.

I still think Hans macro is the final one that I would use, but it is interesting to see the alternative, IMO, so just for that reason I will look a bit further at my alternative,
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Extract missing dates for each person

Post by YasserKhalil »

That's working now. Thank you very much for your great efforts.

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Extract missing dates for each person

Post by Doc.AElstein »

Just a question out of interest, why do you use 1000?
Why not the last row of data like 463?
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Extract missing dates for each person

Post by YasserKhalil »

No specific reason. I just wanted to adjust the code to be the same last row hard-coded.

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Extract missing dates for each person

Post by Doc.AElstein »

I have done another couple of versions, just out of interest.

I have also adjusted the code to be the same last row, but in these two versions the last row is not hard coded. I am using the last row of data. So that is found dynamically.

Because we use the same last row, I can simplify a few things.

The difference between the two new versions is that
_ one uses the conventional Transpose function to do a couple of transposing.
_ In the other one, the same transposing is done in that strange Index function way that I personally like to do.

The full workings are here:
https://excelfox.com/forum/showthread.p ... #post15434
https://excelfox.com/forum/showthread.p ... #post15436

I have modified those full workings to come up with two new functions. ( The first macro needs also one extra Column Letter function )

To help avoid confusion, I will post each macro in a separate post, with an uploaded file , which once again is based on your original data.
In both workbooks is also a version of Hans macro which you can see gives the same results as mine.
( The macros do not use the helper column this time. They use Column B )

Alan

_.___________________________________

P.S. Just as an example of what the next two macros are based on ,
This is the one code line which will get you dynamically the list, for the missing dates, based on the name in cell I1 ,using on your original data.


Transpose Function Way

Code: Select all

 Sub SingleLinePretty3dTranspose() ' Activate  Sheet1  to try this
Dim M As Long: Let M = Worksheets("Sheet1").Range("A" & Worksheets("Sheet1").Rows.Count & "").End(xlUp).Row
 Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(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)")), "#"), "#0", ""), 2), "#")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(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)")), "#"), "#0", ""), 2), "#")), 1)
End Sub
Index Function Way
Here below is the equivalent for the way using the Index to do the transposing

Code: Select all

 Sub ShortPretty3d()  ' Activate  Sheet1  to try this 
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
The Function Missings( ) is based on these code lines.
That function is the main thing that my alternatives are based on.
They are basically similar to the right hand side of the long code lines in those above code snippets, since that returms us a ( vertical ) arrray which we can paste into a soreadsheet, ( or as a prelude to that we have an array, arrStrTemp() , which contains the row number of the required rows from the Check Dates list which correspond to the missing dates )
Last edited by Doc.AElstein on 08 Mar 2021, 08:17, edited 9 times in total.
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Extract missing dates for each person

Post by Doc.AElstein »

The main macro in this and the next post , Sub EvaluateRangeFormulaWay() , are identical. Its just the functions they use that are different.
( Note this macro in this post requires the two Functions given. The macro in the next post needs just the one Function given in that next post)

Code: Select all

'  Index  Way
Sub EvaluateRangeFormulaWay()  '   https://eileenslounge.com/viewtopic.php?f=30&t=36224&p=281397#p281397
Rem 0 worksheets info
Dim Ws1 As Worksheet, Ws2 As Worksheet
 Set Ws1 = ThisWorkbook.Worksheets.Item("Sheet1"): Set Ws2 = ThisWorkbook.Worksheets.Item("Sheet2Alan")
Dim Em1 As Long: Let Em1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim arrA1() As Variant: Let arrA1() = Ws1.Range("A1:A" & Em1 & "").Value2  '  All names list
Rem 1
Dim Dik1 As Object: Set Dik1 = CreateObject("Scripting.Dictionary")
' 1b) make list of unique names
Dim Cnt
    For Cnt = 2 To Em1 ' Looping down all names
     Let Dik1(arrA1(Cnt, 1)) = "This can be anything you like, it don't really matter. What happens here is that we try to put this text in the Item of a dictionary entry that has the key of  the value of    arrA1(Cnt, 1)       If that entry does not exist, then the dictionary is programmed not to error , but instead make ( Add )  an entry with that key value.    For our purposes we don't care what the items are.  But at the end of this loop we will have effectively  Added  a element in the dictionary, one for each of the unique name values.  We can then use the  Keys()  array as a convenient way to get an array of unique names"
    Next Cnt
Dim arrUnics() As Variant: Let arrUnics() = Dik1.Keys() ' This is an array of our  unique  Names
Rem 2 Do it
Dim R3Lne As Long: Let R3Lne = 2    ' This is the next free line in second worksheet
    For Cnt = 0 To UBound(arrUnics()) ' looping through all uniques names
    Dim arrMisins() As Variant: Let arrMisins() = Missings(arrUnics(Cnt))  '## Go to the function that makes an array of the  Missing  dates   based on the  Name value
    Dim NoMisins As Long: Let NoMisins = UBound(arrMisins(), 1)
     Let Ws2.Range("A" & R3Lne & ":A" & R3Lne + (NoMisins - 1) & "").Value = arrUnics(Cnt) ' Put the name in as many cells as we have  missing  dates
     Let Ws2.Range("B" & R3Lne & ":B" & R3Lne + (NoMisins - 1) & "").Value = arrMisins()   ' Put the missing dates in
     Let R3Lne = R3Lne + NoMisins  ' This is the next free line in second worksheet
    Next Cnt
 
 Let Ws2.Range("B2:B" & Ws2.UsedRange.Rows.Count + 1 & "").NumberFormat = "yyyy/mm/dd"
End Sub
Public Function CL(ByVal lclm As Long) As String '         http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
    Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function
Function Missings(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(Worksheets("Sheet1").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 Missings = 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
You do not have the required permissions to view the files attached to this post.
Last edited by Doc.AElstein on 08 Mar 2021, 08:22, edited 1 time in total.
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Extract missing dates for each person

Post by Doc.AElstein »

Code: Select all

'  Transpose   Way
Sub EvaluateRangeFormulaWay()  '   https://eileenslounge.com/viewtopic.php?f=30&t=36224&p=281397#p281397
Rem 0 worksheets info
Dim Ws1 As Worksheet, Ws2 As Worksheet
 Set Ws1 = ThisWorkbook.Worksheets.Item("Sheet1"): Set Ws2 = ThisWorkbook.Worksheets.Item("Sheet2Alan")
Dim Em1 As Long: Let Em1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim arrA1() As Variant: Let arrA1() = Ws1.Range("A1:A" & Em1 & "").Value2  '  All names list
Rem 1
Dim Dik1 As Object: Set Dik1 = CreateObject("Scripting.Dictionary")
' 1b) make list of unique names
Dim Cnt
    For Cnt = 2 To Em1 ' Looping down all names
     Let Dik1(arrA1(Cnt, 1)) = "This can be anything you like, it don't really matter. What happens here is that we try to put this text in the Item of a dictionary entry that has the key of  the value of    arrA1(Cnt, 1)       If that entry does not exist, then the dictionary is programmed not to error , but instead make ( Add )  an entry with that key value.    For our purposes we don't care what the items are.  But at the end of this loop we will have effectively  Added  a element in the dictionary, one for each of the unique name values.  We can then use the  Keys()  array as a convenient way to get an array of unique names"
    Next Cnt
Dim arrUnics() As Variant: Let arrUnics() = Dik1.Keys() ' This is an array of our  unique  Names
Rem 2 Do it
Dim R3Lne As Long: Let R3Lne = 2    ' This is the next free line in second worksheet
    For Cnt = 0 To UBound(arrUnics()) ' looping through all uniques names
    Dim arrMisins() As Variant: Let arrMisins() = Missings(arrUnics(Cnt))  '## Go to the function that makes an array of the  Missing  dates   based on the  Name value
    Dim NoMisins As Long: Let NoMisins = UBound(arrMisins(), 1)
     Let Ws2.Range("A" & R3Lne & ":A" & R3Lne + (NoMisins - 1) & "").Value = arrUnics(Cnt) ' Put the name in as many cells as we have  missing  dates
     Let Ws2.Range("B" & R3Lne & ":B" & R3Lne + (NoMisins - 1) & "").Value = arrMisins()   ' Put the missing dates in
     Let R3Lne = R3Lne + NoMisins  ' This is the next free line in second worksheet
    Next Cnt
 
 Let Ws2.Range("B2:B" & Ws2.UsedRange.Rows.Count + 1 & "").NumberFormat = "yyyy/mm/dd"
End Sub

Function Missings(ByVal Nme As String) As Variant
Dim M As Long: Let M = Worksheets("Sheet1").Range("A" & Worksheets("Sheet1").Rows.Count & "").End(xlUp).Row
 Let Missings = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(Worksheets("Sheet1").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)")), "#"), "#0", ""), 2), "#")), 1)
End Function
You do not have the required permissions to view the files attached to this post.
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Extract missing dates for each person

Post by YasserKhalil »

Thank you very much Mr. Alan
Best and Kind Regards