Appendix Thread. 3 TEST COPY

**DocAElstein** · 01-24-2021, 07:33 PM

macro for last two posts

Code:

Option Explicit
Sub Transfer_marasAlan_3()  '   https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624
Dim a(), cls_v() As String, Rws(), aSum(), arrOut__(), JagdDikIt()
Dim Rng As Range, Rng_v As Range, cel As Range
Dim Wrbk As Workbook, Rw As Long
Dim Pth As String
 Let Pth = ThisWorkbook.Path & Application.PathSeparator  '       Const pth = "C:\Users\L026936\Desktop\Excel\"      '<---- use own path
Const Wnm = "Workbook2_3.xlsx"                             'your workbook name
'    Application.ScreenUpdating = False
Rem 1 the main data range from source
    With ThisWorkbook.Sheets("Sheet1")
     Set Rng = .Range("a1:ai" & 36 & "")    '   main data range    hard coded to 36  for testing and  demonstration         .UsedRange.Rows.Count)
     Let a() = Rng.Value                    '   all data values in the source.  This will end up in the tyopical    arrOut()=AppIndex( a(), Rws(),  Clms() )
     Set Rng_v = Rng.Columns(2).SpecialCells(xlCellTypeVisible)  '  this gives us the range we see , (it is likely as a collection of areas) in the ID column
        If Rng_v.Count > 1 Then
   Rem 2 Make the sums column array, aSum() , and while we are looping we will collect the seen row indicies, Rws()
'       ' ddddddddddddddddddddddd Dictionaray bit ------
        '  Dictionaray    -   The only reason to use this is that its a convenient way to get a unique list thing, or a unique set of things.
        Dim Dik As Object: Set Dik = CreateObject("Scripting.Dictionary")   '      https://excelmacromastery.com/vba-dictionary/
        'Dim d As Scripting.Dictionary: Set d = New Scripting.Dictionary
        Dim aTp() As Variant: ReDim aTp(1 To 3) ' This is a temporary array used to fill the dictionary  Items   it must be dynamic and variant type  - see note +++ below
            For Each cel In Rng_v  '   we effectivelly are going down all the seen rows
                If cel.Row > 1 And cel.Value <> "" Then
                 Let Rw = cel.Row
                    If Not Dik.exists(a(Rw, 2)) Then ' -Case we don't yet have any dictionaray item with this ID  key
                     Let aTp(1) = Rw                                          '  row number
                     Let aTp(2) = a(Rw, 35)                                   '  grangtotal for this row
                     Let aTp(3) = .Evaluate("=Sum(o" & Rw & ": z" & Rw & ")") ' Our  column Sums
                     Dik.Add Key:=a(Rw, 2), Item:=aTp() '   The key becomes the ID  ,      The Item is a three element array of      the row number     the columns sum for this row    the gradtotal for this row                              shothand way to do this line is  d(a(r, 2)) = atp
                    Else '                           ' -Case we already have a dictionary item with this key
                     Let aTp() = Dik.Item(a(Rw, 2)) ' we are returning an item that is an array, so the recieving array variable must be dynamic.  the returned element type3s are  Variant   +++
                        If a(Rw, 35) > aTp(2) Then  '  If the grand total for this row and  ID  is  greater than a previous, then ....
                            Let aTp(1) = Rw                                        '   we are replacing ..
                            Let aTp(2) = a(Rw, 35)                                 '    .. the item with the relavent  ..
                            Let aTp(3) = .Evaluate("=Sum(o" & Rw & ": z" & Rw & ")") '    .. info from this row
                            Dik(a(Rw, 2)) = aTp()  '  shorthand version for   Dik.Add  Key:=a(Rw, 2), Item:=aTp()
                        End If
                    End If ' end of making or replacing  a dictiuonary item
                Else
                End If
            Next
        ' at this point we have a dictionary that has one  Item  for each  ID
        ' in this last  Dik  bit we use the first and third part  of the 3 element items  in  a pseudo   arrOut()=AppIndex( arrUnjaggedJaged(), Rws() , Clms() )    '    https://www.ozgrid.com/forum/index.php?thread/1227920-slicing-a-2d-array/&postID=1239241#post1239241
            If Dik.Count Then
                'Let JagdDikIt() = Application.Transpose(Dik.items()) '    we can treat an unjagged jagged array  that is a 1 D array of 1 D arrays as if it was a  2 D array  ...   https://eileenslounge.com/viewtopic.php?p=266691#p266691
                Let JagdDikIt() = Dik.items()
                'Let Rws() = Application.Index(JagdDikIt(), 1, Evaluate("row(1:" & UBound(JagdDikIt(), 2) & ")"))                                          '   Application.Transpose(Application.Transpose(Application.Index(v, 1, Evaluate("row(1:" & UBound(v, 2) & ")"))))
                Let Rws() = Application.Index(JagdDikIt(), Evaluate("row(1:" & UBound(JagdDikIt()) + 1 & ")"), 1)                                        '   Application.Transpose(Application.Transpose(Application.Index(v, 1, Evaluate("row(1:" & UBound(v, 2) & ")"))))
                'Let aSum() = Application.Index(JagdDikIt(), 3, Evaluate("row(1:" & UBound(JagdDikIt(), 2) & ")"))                         'Application.Transpose(Application.Transpose(Application.Index(v, 3, Evaluate("row(1:" & UBound(v, 2) & ")"))))
                Let aSum() = Application.Index(JagdDikIt(), Evaluate("row(1:" & UBound(JagdDikIt()) + 1 & ")"), 3)                       'Application.Transpose(Application.Transpose(Application.Index(v, 3, Evaluate("row(1:" & UBound(v, 2) & ")"))))
'       ' ddddddddddddddddddddddddd -----------------------------
            Else
            End If
        Else ' case only a header row to be seen
        End If
    End With
    If Rng_v.Count = 1 Or Dik.Count = 0 Then
        MsgBox "No rows to transfer."
        Exit Sub
    End If
    On Error Resume Next   '   https://eileenslounge.com/viewtopic.php?f=30&t=35861&start=20
     Set Wrbk = Workbooks(Wnm)
        If Wrbk Is Nothing Then
         Workbooks.Open Filename:=Pth & Wnm
        Else
         Workbooks(Wnm).Activate
        End If
    On Error GoTo 0
    With ActiveWorkbook
        With .Sheets("Sheet1")
        Dim vTemp As Variant ' just for demo purposes
         Let vTemp = .UsedRange.Rows(1)
         ' { empty ,  Unique ID  , Gap ,Name  ,  Title ,  Platform  ,  Salary , Gap, Total ,  copy1  , copy2 ,  copy3 ,  copy4  , copy5 ,  copy6 ,  copy7 ,  copy2 ,  copy3 ,  copy4 ,  copy5  , copy6 ,  copy7 ,  Formula7   , Formula8 ,   Formula9  }
         Let vTemp = Rng.Rows(1)
         ' { Number , ID , Name ,   Title ,  Platform ,   Filter  ,  ,  ,   ,    ,Salary ,   ,    ,   ,Add1  ,  Add2 ,   Add3  ,  Add4  ,  Add5 ,   Add6 ,   Add7  ,  Add8 ,   Add9 ,   Add10 ,  Add11 ,  Add12 ,  copy1 ,  copy2 ,  copy3 ,  copy4 ,  copy5  , copy6 ,  copy7  , Total ,  grandtotal  }
         Let vTemp = Application.Match(.UsedRange.Rows(1), Rng.Rows(1), 0) '  This gives a 1 D array and each element has either the position of the header in the destination workbook, or an error if it did not find it
         '  { 2 ,  error  , 3  , 4 ,  5 ,  11  , error  , 34 ,  27 ,  28 ,  29  , 30 ,  31 ,  32 ,  33 , 28 , error ,error ,error ,error ,error ,error ,error ,error ,error ,   }
         ' So the above line tells us where there is an error in a match with the header names
         Let vTemp = Application.IfError(vTemp, "x") ' Instead of the vbError , a text of  "x"  is put into the array
         '  { 2 ,  x   , 3  , 4 ,  5 ,  11  , x , 34  ,  27 ,  28 ,  29  , 30 ,  31 ,  32 ,  33 , x ,x ,x ,x ,x ,x ,x ,x ,x ,  }
         Let vTemp = Filter(vTemp, "x", False, 0) ' take out the  "x"s
         '  { 2    , 3  , 4 ,  5 ,  11   , 34,  27 ,  28 ,  29  , 30 ,  31 ,  32 ,  33  }
         Let cls_v() = Filter(Application.IfError(Application.Match(.UsedRange.Rows(1), Rng.Rows(1), 0), "x"), "x", False, 0)
         '  { 2   , 3  , 4 ,  5 ,  11  ,   27 ,  28 ,  29  , 30 ,  31 ,  32 ,  33  }
            With .Range("B2")  '   .UsedRange.Offset(1)
             ' .Resize(, 15).ClearContents
             Let arrOut__() = Application.Index(a(), Rws(), cls_v())
             .Resize(UBound(Rws()), 1) = arrOut__()
             Let Rws() = Evaluate("row(1:" & UBound(Rws()) & ")") '  Using the variable  Rws()  for a sequential indicie list  1; 2; 3 ... etc for all rows in the  arrOut__()
             .Offset(, 2).Cells(1).Resize(UBound(Rws()), 4).Value = Application.Index(arrOut__(), Rws(), Array(2, 3, 4, 5))  '  columns   D - G
             .Offset(, 7).Cells(1).Resize(UBound(Rws())) = aSum()  '  columm I
             .Offset(, 8).Cells(1).Resize(UBound(Rws()), 7).Value = Application.Index(arrOut__(), Rws(), Array(6, 7, 8, 9, 10, 11, 12))  ' Column J to P
            End With
        End With
'        .Save
    End With
'    Set Rng = Nothing
'    Set Rng_v = Nothing
'    Set cel = Nothing
    Set Dik = Nothing
End Sub

**DocAElstein** · 02-09-2021, 10:52 PM

In suppot of this thread
https://excelfox.com/forum/showthrea...5292#post15292

Input data

_____ Workbook: VBA3.xls ( Using Excel 2007 32 bit )

_Row\^Col	A	B	C	D	F
1	Find word	1Abc	2wer#	3smar	4chris
2	AP1k		AP1k, 6-9\| AP1k, 10-13
3	ForCome			ForCome, 13-19
4
5	Double		Double, 14-16 \| Double, 14-16\| Double, 14-16	Double, 14-16\| Double, 14-16	Double, 14-16\| Double, 14-16

Worksheet: inputA

Wanted Output

_____ Workbook: VBA3.xls ( Using Excel 2007 32 bit )

_Row\^Col	A	B
1	Output
2	1Abc
3	2wer#	AP1k, 6-9
4	2wer#	AP1k, 10-13
5	2wer#	Double, 14-16
6	2wer#	Double, 14-16
7	2wer#	Double, 14-16
8	3smar	ForCome, 13-19
9	3smar	Double, 14-16
10	3smar	Double, 14-16
11	4chris	Double, 14-16
12	4chris	Double, 14-16

Worksheet: OutputB

Results after running macro in next post

_____ Workbook: VBA3.xls ( Using Excel 2007 32 bit )

_Row\^Col	A	B
1
2	1Abc
3	2wer#	AP1k, 6-9
4	2wer#	AP1k, 10-13
5	2wer#	Double, 14-16
6	2wer#	Double, 14-16
7	2wer#	Double, 14-16
8	3smar	ForCome, 13-19
9	3smar	Double, 14-16
10	3smar	Double, 14-16
11	4chris	Double, 14-16
12	4chris	Double, 14-16

Worksheet: Output

**DocAElstein** · 02-09-2021, 10:53 PM

Macro for last post

Code:

Option Explicit
Sub StartOffvbadumbarse()
Rem 1 Worksheets info
Dim WsIn As Worksheet, WsOut As Worksheet
 Set WsIn = ThisWorkbook.Worksheets.Item(1): Set WsOut = ThisWorkbook.Worksheets.Item(2)
Dim arrIn() As Variant: Let arrIn() = WsIn.Range("B1:F5").Value2
Rem 2
'2b
Dim Clm As Long
    For Clm = 1 To 5 Step 1
        If arrIn(1, Clm) = "" Then
        ' Nothing to do for no header
        Else
        Dim Itms As String: Let Itms = arrIn(1, Clm)
        Dim RwDta As Long
            For RwDta = 2 To 5 Step 1
            Dim strFndWd As String
                If arrIn(RwDta, Clm) = "" Then
                ' no data
                Else
                    If InStr(1, arrIn(RwDta, Clm), "|", vbBinaryCompare) > 0 Then ' we must have two or more datas seperatied by a  |
                    Dim CelDts As Long
                        For CelDts = 0 To UBound(Split(arrIn(RwDta, Clm), "|", -1, vbBinaryCompare))
                         Let strFndWd = strFndWd & Split(arrIn(RwDta, Clm), "|", -1, vbBinaryCompare)(CelDts) & vbCr & vbLf
                        Next CelDts
                    Else ' case single data
                     Let strFndWd = strFndWd & arrIn(RwDta, Clm) & vbCr & vbLf  ' effectively a single row is added for this data
                    End If
                End If
            Next RwDta
        '2e we have been through the data, so time to see what we got and fill our two strings appropriately
        Dim strOutA As String, strOutB As String
            If strFndWd = "" Then ' case we had no data
             Let strFndWd = strFndWd & vbCr & vbLf ' effectively adds an empty row
             Let strOutA = strOutA & Itms & vbCr & vbLf ' a single row with header
            Else ' we have data, so need do add some rows to strOutA ( strOutB effecively has all the rows determined by the number of  vbCr & vbLf   added
            Dim RwCnt As Long: Let RwCnt = UBound(Split(strFndWd, vbCr & vbLf, -1, vbBinaryCompare)) + 1 - 1 ' The number of  vbCr & vbLf  gives us the number rows
                For CelDts = 1 To RwCnt
                 Let strOutA = strOutA & Itms & vbCr & vbLf
                Next CelDts
            End If
        End If
     Let strOutB = strOutB & strFndWd
     Let strFndWd = ""
    Next Clm
' I can view my data in a message box or in the immediate window
 MsgBox Prompt:=strOutA: Debug.Print strOutA
 MsgBox Prompt:=strOutB: Debug.Print strOutB

Rem 3 outout
Dim arrOutA() As String: Let arrOutA() = Split(strOutA, vbCr & vbLf, -1, vbBinaryCompare) '  Excel has the convention of taking a  1D  array as being "horizontal" for spreadsheet purposes, so will consider it as a row of data values if applied to a worksheet range
Dim arrOutB() As String: Let arrOutB() = Split(strOutB, vbCr & vbLf, -1, vbBinaryCompare)
' Let WsOut.Range("A2").Resize(UBound(arrOutA()), 1).Value = Application.Transpose(arrOutA())
 Let WsOut.Range("A2").Resize(UBound(arrOutA()), 1).Value = Application.Index(arrOutA(), Evaluate("=row(1:" & UBound(arrOutA()) & ")/row(1:" & UBound(arrOutA()) & ")"), Evaluate("=row(1:" & UBound(arrOutA()) & ")"))
' Let WsOut.Range("B2").Resize(UBound(arrOutB()), 1).Value = Application.Transpose(arrOutB())
 Let WsOut.Range("B2").Resize(UBound(arrOutB()), 1).Value = Application.Index(arrOutB(), Evaluate("=row(1:" & UBound(arrOutB()) & ")/row(1:" & UBound(arrOutB()) & ")"), Evaluate("=row(1:" & UBound(arrOutB()) & ")"))
End Sub

**DocAElstein** · 02-27-2021, 06:17 PM

for later use

**DocAElstein** · 02-27-2021, 06:18 PM

In support of this post
http://www.eileenslounge.com/viewtop...281164#p281164

Code:

Sub On___Then____()  '    http://www.eileenslounge.com/viewtopic.php?p=281164#p281164
' Going nowhere    the first   ____ evaluates to a number in range 0  or 2 , 3, 4 ..... 255 so I don't  GoTo
On 0.2 GoTo NeverBeHere
On Err GoTo NeverBeHere
On TwitTwo GoTo NeverBeHere
On Nmber(255) GoTo NeverBeHere
On -0.5 GoTo NeverBeHere
On 255.49999 GoTo NeverBeHere

' Going somewhere  the first   ____  evaluates to 1  so I  GoTo
On 1 GoTo 10
 MsgBox prompt:="I am never here. You will never see this"
10 On 1.49999 GoTo 20
 MsgBox prompt:="I am never here. You will never see this"
20 On Nmber(0.5001) GoTo 30
 MsgBox prompt:="I am never here. You will never see this"
30  Exit Sub
'
NeverBeHere:
' I will never be here
 MsgBox prompt:="I am never here. You will never see this"
End Sub
Function TwitTwo() As Double
 Let TwitTwo = 2.1
End Function
Function Nmber(ByVal No As Double) As  Double 
 Let Nmber = No
End Function

**DocAElstein** · 03-05-2021, 05:17 PM

Post for later use

**DocAElstein** · 03-05-2021, 05:17 PM

Some notes from this question:
http://www.eileenslounge.com/viewtop...281312#p281312
Yasser Question.JPG

Question …
http://www.eileenslounge.com/viewtopic.php?f=30&t=36224

_____ Workbook: Extract missing dates for each person.xlsm ( Using Excel 2007 32 bit )

_Row\^Col	A	B	C	F	G	I	T	U
1	Name	Dates	Helper	Check Dates	Result	aa		Yasser Given
2	aa	2021-02-19	2021-02-19	2021-01-26	2021-01-26		2021-01-29	2021-01-29
3	aa	2021-01-26	2021-01-26	2021-01-27	2021-01-27		2021-01-30	2021-01-30
4	aa	2021-01-27	2021-01-27	2021-01-28	2021-01-28		2021-02-05	2021-02-05
5	aa	2021-01-28	2021-01-28	2021-01-29	Missing		2021-02-12	2021-02-12
6	aa	2021-01-31	2021-01-31	2021-01-30	Missing
7	aa	2021-02-01	2021-02-01	2021-01-31	2021-01-31
8	aa	2021-02-02	2021-02-02	2021-02-01	2021-02-01
9	aa	2021-02-03	2021-02-03	2021-02-02	2021-02-02
10	aa	2021-02-04	2021-02-04	2021-02-03	2021-02-03
11	aa	2021-02-06	2021-02-06	2021-02-04	2021-02-04
12	aa	2021-02-07	2021-02-07	2021-02-05	Missing
13	aa	2021-02-08	2021-02-08	2021-02-06	2021-02-06
14	aa	2021-02-09	2021-02-09	2021-02-07	2021-02-07
15	aa	2021-02-10	2021-02-10	2021-02-08	2021-02-08
16	aa	2021-02-11	2021-02-11	2021-02-09	2021-02-09
17	aa	2021-02-13	2021-02-13	2021-02-10	2021-02-10
18	aa	2021-02-14	2021-02-14	2021-02-11	2021-02-11
19	aa	2021-02-15	2021-02-15	2021-02-12	Missing
20	aa	2021-02-16	2021-02-16	2021-02-13	2021-02-13
21	aa	2021-02-17	2021-02-17	2021-02-14	2021-02-14
22	aa	2021-02-18	2021-02-18	2021-02-15	2021-02-15
23	aa	2021-02-20	2021-02-20	2021-02-16	2021-02-16
24	aa	2021-02-21	2021-02-21	2021-02-17	2021-02-17
25	aa	2021-02-22	2021-02-22	2021-02-18	2021-02-18
26	aa	2021-02-23	2021-02-23	2021-02-19	2021-02-19
27	aa	2021-02-24	2021-02-24	2021-02-20	2021-02-20
28	aa	2021-02-25	2021-02-25	2021-02-21	2021-02-21
29	bb	2021-01-27	2021-01-27	2021-02-22	2021-02-22
30	bb	2021-01-28	2021-01-28	2021-02-23	2021-02-23
31	bb	2021-01-31	2021-01-31	2021-02-24	2021-02-24
32	bb	2021-02-01	2021-02-01	2021-02-25	2021-02-25
33	bb	2021-02-03	2021-02-03

Worksheet: Sheet1

**DocAElstein** · 03-05-2021, 05:26 PM

Continued from last post: Some notes from this question:
http://www.eileenslounge.com/viewtop...281312#p281312
Yasser Question.JPG https://excelfox.com/forum/showthrea...ll=1#post15418

Hans Solution. What’s he doing:

Rem 1 Make dictionary of Dictionaries2
There are two dictionary variables.
The first one contains all the unique name values from column A . So this is the unique names dictionary
We loop down to build that dictionary, and the solution is relying on a un unbroken sequential list of names, in other words no mixed up , but an order list like
Name1
Name1
Name1
Name2
Name2
..etc.
In that main loop , all the values, from column B are put in the Item ( which is itself a dictionary ) of each unique name in the unique names dictionary.
This is the clever line that does that. The line is done for each row in the data to be looked in ( column B )
Let dct1(rng1(r1, 1))(Int(rng1(r1, 2))) = 1
The 1 is arbitrary. What we are doing is like referring to ( trying to put 1 into ) the key of an item in the second dictionary that does not exist. When this is done, rather than error, the Scripting.Dictionary is programmed to make an item with that key.
The end result of all this is that we end up with a main dictionary that has a key for each unique name. The item for each name / Key has a second dictionary in it of all the Integer parts of the Date & time in column B. ( The dictionary will be seeing the basic Excel .Vaue2 of the date & time, so the Integer part will be just the date.
Here is a pseudo couple of code lines to demo that last bit

Dick1(Name1) ( 2021-02-19 ) = 1
Dick1(Name1) ( 2021-01-26 ) = 1

You see what’s going on is the following:
Dick1(Name1) will always return the same thing which is the Item in Dick1 with the Key of Name1
So Effectively those lines are pseudo

Dick2 ( 2021-02-19 ) = 1
Dick2 ( 2021-01-26 ) = 1

What those code lines try to do is put a 1 in the items of a Dick2 element that does not exist. As noted, the Scripting.Dictionary is programmed to make an item with that key rather than error if such an action is attempted.
So that is just a convenient way to make the second dictionaries – Note I said dictionaries

We end up with this:
Dick1 keys

Dick2KeysWichAreDicksInDick1Items.jpg

These lines give me that from doing a Shift F9 on any variable
Shift F9 on vTemps for Watch Window.JPG http://i.imgur.com/Ms7HmG6.jpg

Rem 2
We have an Outer loop and an inner loop in it.
__The outer loop is done once for each unique name, so for each key of the main dictionary
____The inner loop goes down the entire F column Check dates and does a write out any missing dates, that is to say dates not in the dictionary that is the item for that unique name, key of the main dictionary

Hans macro

Code:

Option Explicit
Sub ListMissing()  '  ' Hans    http://www.eileenslounge.com/viewtopic.php?p=281312#p281312
Dim vTemp1, vTemp2 ' For development and debug
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 dcTemp2 As Object
Dim n As Variant
 Set dct1 = CreateObject("Scripting.Dictionary")
 Set wsh1 = Worksheets("Sheet1")
 Let m1 = wsh1.Range("A" & wsh1.Rows.Count).End(xlUp).Row
 Let rng1 = wsh1.Range("A2:B" & m1).Value
Rem 1  Make dictionary of Dictionaries
    For r1 = 1 To UBound(rng1)
        If Not dct1.Exists(rng1(r1, 1)) Then ' this gives us  3 elements in  the  dct1  that have like key  aa  and  the item is an empty dictionary object
         Set dcTemp2 = CreateObject("Scripting.Dictionary") ' This effectively clears the variable used temporarily
         dct1.Add Key:=rng1(r1, 1), Item:=dcTemp2
        End If
     Let dct1(rng1(r1, 1))(Int(rng1(r1, 2))) = 1 ' the  1  is arbritrary, we effectively create a Key looking like  aa 2021-02-19 in the  second dictionary that is the item of the unique
    Next r1
 vTemp1 = dct1.keys()  '  Dick1.JPG                                http://i.imgur.com/zTWYpuy.jpg
 vTemp2 = dct1.items() '  Dick2KeysWichAreDicksInDick1Items.jpg    http://i.imgur.com/Jsd2kXS.jpg
'
 Let m2 = wsh1.Range("F" & wsh1.Rows.Count).End(xlUp).Row
 Let rng2 = wsh1.Range("F2:F" & m2).Value
'
 Set wsh2 = Worksheets("Sheet2Hans")
 wsh2.Range("A2:B" & wsh2.Rows.Count).Clear
 
 
 Rem 2  Go through checking for existance of an Item. For no existance , then that is missing data
  Let r3 = 1
    ' The outer loop is done once for each unique name, so for each key of the main dictionary ===========
    For Each n In dct1.keys '  this and next line make it  For Each  of .._
     Set dcTemp2 = dct1(n)  ' _.. the dictionries within each item of  Dick1  In other words  For Each  Name
        ' -----------------------------------------------
        ' The inner loop goes down the entire  F column Check dates and does a write out any  missing dates, that is to say dates not in the dictionary that is the item for that  unique name,  key of the main dictionary
        For r2 = 1 To UBound(rng2) ' Going down the entire   F  range
            If Not dcTemp2.Exists(rng2(r2, 1)) Then
             Let r3 = r3 + 1
             Let wsh2.Range("A" & r3).Value = n           '  n is the key, the unique name, in the main large dictionary
             Let wsh2.Range("B" & r3).Value = rng2(r2, 1) ' This will be the missing entry
            Else
            End If
        Next r2 ' ________________________________________
    
    Next n ' ==============================================================================================
End Sub

**DocAElstein** · 03-05-2021, 10:51 PM

Some notes for this question:
http://www.eileenslounge.com/viewtop...281291#p281291

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, …. _

Code:

Sub BasicOneLine() '  '....  http://www.eileenslounge.com/viewtopic.php?p=281291#p281291
 Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(Split(Replace(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", ""), "0#", ""), "#", -1), Evaluate("=row(1:" & UBound(Split(Replace(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", ""), "0#", ""), "#", -1)) + 1 & ")/row(1:" & UBound(Split(Replace(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", ""), "0#", ""), "#", -1)) + 1 & ")"), Evaluate("=row(1:" & UBound(Split(Replace(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", ""), "0#", ""), "#", -1)) + 1 & ")")), 1), 1), 1).Value = _
 Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(Split(Replace(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", ""), "0#", ""), "#", -1), Evaluate("=row(1:" & UBound(Split(Replace(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", ""), "0#", ""), "#", -1)) + 1 & ")/row(1:" & UBound(Split(Replace(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", ""), "0#", ""), "#", -1)) + 1 & ")"), Evaluate("=row(1:" & UBound(Split(Replace(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", ""), "0#", ""), "#", -1)) + 1 & ")")), 1)
End Sub

Before
_____ Workbook: Extract missing dates for each person.xlsm ( Using Excel 2007 32 bit )

_Row\^Col	I	U
1	aa	Yasser Given
2		2021-01-29
3		2021-01-30
4		2021-02-05
5		2021-02-12
6

Worksheet: Sheet1

After
_____ Workbook: Extract missing dates for each person.xlsm ( Using Excel 2007 32 bit )

_Row\^Col	I	T	U
1	aa		Yasser Given
2		2021-01-29	2021-01-29
3		2021-01-30	2021-01-30
4		2021-02-05	2021-02-05
5		2021-02-12	2021-02-12
6

Worksheet: Sheet1

Run Sub BasicOneLine() on the uploaded file to demo those results

**DocAElstein** · 03-05-2021, 11:11 PM

extended coding notes for last post
https://excelfox.com/forum/showthrea...ll=1#post15420

Code:

Sub Pretty2()  '
Dim arrTemp() As Variant
Rem  To get the results in  column  T  ( same as
 ' Ths first forumula give 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)"))
 ' The next few lines get rid of the  0s
Dim StrTemp As String: Let StrTemp = Join(arrTemp(), "#") ' Convert the array to a string with a  #  in between each data
 Let StrTemp = Replace(StrTemp, "#0", "", 1, -1, vbBinaryCompare): StrTemp = Replace(StrTemp, "0#", "", 1, -1, vbBinaryCompare) ' This effectiveely removes the  0s   data ( and its seperator )
Dim arrStrTemp() As String: Let arrStrTemp() = Split(StrTemp, "#", -1, vbBinaryCompare) ' remake the array
 ' 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
 Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
 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
 
 ' Or
 
 Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(Split(Replace(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", ""), "0#", ""), "#", -1), Evaluate("=row(1:" & UBound(Split(Replace(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", ""), "0#", ""), "#", -1)) + 1 & ")/row(1:" & UBound(Split(Replace(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", ""), "0#", ""), "#", -1)) + 1 & ")"), Evaluate("=row(1:" & UBound(Split(Replace(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", ""), "0#", ""), "#", -1)) + 1 & ")")), 1), 1), 1).Value = _
 Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(Split(Replace(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", ""), "0#", ""), "#", -1), Evaluate("=row(1:" & UBound(Split(Replace(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", ""), "0#", ""), "#", -1)) + 1 & ")/row(1:" & UBound(Split(Replace(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", ""), "0#", ""), "#", -1)) + 1 & ")"), Evaluate("=row(1:" & UBound(Split(Replace(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", ""), "0#", ""), "#", -1)) + 1 & ")")), 1)
 

 
  
 
 
Stop
 
 '  Replace(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", ""), "0#", "")
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
Rem  To get to  Column N  in   Extract missing dates for each person.xlsm
 ' Ths first forumula give 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
 ' The next step is to replace the errors with  0s
 Let arrTemp() = Evaluate("=IFERROR(IF(F2:F463=0,0,MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1),0)),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
 ' 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)"))
 ' The next few lines get rid of the  0s
'Dim StrTemp As String
 Let StrTemp = Join(arrTemp(), "#") ' Convert the array to a string with a  #  in between each data
 Let StrTemp = Replace(StrTemp, "#0", "", 1, -1, vbBinaryCompare) ' This effectiveely removes the  0s   data ( and its seperator )
'Dim arrStrTemp() As String
 Let arrStrTemp() = Split(StrTemp, "#", -1, vbBinaryCompare) ' remake the array
 ' 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(Range("C2:C463"), arrTemp(), 1) ' finally we want the  dates  ( so far we have the row indicies obtained from  Match
 Let Range("N2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
 Let Range("N2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd" '  from macro recorder .NumberFormat = "[$-1010000]yyyy/mm/dd,@"
 
 
 
 
 ' Or
 
 
 
 
 
'  Let arrTemp() = Evaluate("=If({1},IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0))")

 
 'let worksheets("Sheet2").range
'v = Join(v, "#")                                             '  https://www.vbarchiv.net/commands/cmd_filter.html
'
'
'v = Application.Index(Range("C2:C463"), Evaluate("=If({1},MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1),0)*($A$2:$A$1000=$I$1))"), 1)
'
'
'v = Application.Index(v, Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))
'v = Evaluate("=IFERROR(INDEX($A$2:$C$1000,MATCH(1,($A$2:$A$1000=$I$1)*($C$2:$C$1000=" & r.Address & "),0),3),""Missing"")")
'
End Sub
Sub BasicOneLine() '  '....  http://www.eileenslounge.com/viewtopic.php?p=281291#p281291