VBA to complete a list with missing items

[bfilip]

Hello,

I have two sheets: Sheet1 and Sheet2. In Sheet1 I have names (Name1, Name2, Name3...) and projects (Project1, Project2...). I mark with an x the name assigned to a project.
In Sheet2 I have have the working days of the calendar and the names with their assigned projects.

I would need some help to finish my VBA code for automating the updating of sheet2 process, meaning I need to search for the "x", get the Name and the Project, go to sheet2, search for the name, look what projects are already there, and if the Project is not there to add it.

I have managed to put together something... or maybe I am not even on the right track, IDK. I think using Find would make it easier but I'm not that familiar with it.

Public Sub SynchonizeProject()[/INDENT]
[INDENT=4]Application.ScreenUpdating = False[/INDENT]
[INDENT=4]    Dim cell2 As Range[/INDENT]
[INDENT=4]    Dim i As Long, j As Long, ii As Long[/INDENT]
[INDENT=4]    Dim arData[/INDENT]
[INDENT=4]    Dim d As New Dictionary[/INDENT]
[INDENT=4]    Dim d2 As New Dictionary[/INDENT]
[INDENT=4]    Dim searchrange[/INDENT]
[INDENT=4]    Dim newtempsearchrange[/INDENT]
[INDENT=4]    Dim k2 As Variant, v2 As Variant[/INDENT]
[INDENT=4]    Dim e As Range, p As Range, e2 As Range, p2 As Range[/INDENT]
[INDENT=4]   [/INDENT]
[INDENT=4]    'The First Employee Names[/INDENT]
[INDENT=4]    Worksheets("Sheet1").Activate[/INDENT]
[INDENT=4]    Set e = Worksheets("Sheet1").Range("D1")[/INDENT]
[INDENT=4]    'The First Project Names[/INDENT]
[INDENT=4]    Set p = Worksheets("Sheet1").Range("B4")[/INDENT]
[INDENT=4]    Set d = CreateObject("Scripting.Dictionary")    'create the Dictionary named d[/INDENT]
[INDENT=4]    Set d2 = CreateObject("Scripting.Dictionary")[/INDENT]
[INDENT=4]    d.RemoveAll                        'clean up the dictionary[/INDENT]
[INDENT=4]    d.CompareMode = vbTextCompare   'set the dicitonary to be case insensitive[/INDENT]
[INDENT=4]    d2.CompareMode = vbTextCompare[/INDENT]
[INDENT=4]    arData = Range(p.End(xlDown), e.End(xlToRight)) 'Set arData range from B5 to the last empty row, from D1 to the last empty cell after names[/INDENT]
[INDENT=4]    For i = 1 To UBound(arData, 1)[/INDENT]
[INDENT=4]    DoEvents[/INDENT]
[INDENT=4]        For j = 1 To UBound(arData, 2)[/INDENT]
[INDENT=4]        DoEvents[/INDENT]
[INDENT=4]        d.RemoveAll                                             'start wit an empty d dictionary[/INDENT]
[INDENT=4]        Set d2 = Nothing[/INDENT]
[INDENT=4]        Set d = Nothing[/INDENT]
[INDENT=4]           If UCase(arData(i, j)) = "X" Then                    'If an "x", not case sensitive, is found[/INDENT]
[INDENT=4]           Dim k As Variant, v As Variant[/INDENT]
[INDENT=4]                k = arData(i, 1)                                'Key: Project-Name[/INDENT]
[INDENT=4]                v = arData(1, j)                                'Value: Employee-Name[/INDENT]
[INDENT=4]                d.Add k, v[/INDENT]
[INDENT=4]                Worksheets("Sheet2").Activate[/INDENT]
[INDENT=4]                Set e2 = Worksheets("Sheet2").Range("B15")[/INDENT]
[INDENT=4]                Set p2 = Worksheets("Sheet2").Range("B100")[/INDENT]
[INDENT=4]                searchrange = Range(e2, p2) 'set search range at a fixed range that contains all the employees and their projects[/INDENT]
[INDENT=4]                    For ii = 1 To UBound(searchrange)           'compare cell in the range (names of employees from Sheet2) with every name in the dictionary[/INDENT]
[INDENT=4]                    DoEvents[/INDENT]
[INDENT=4]                            If searchrange(ii, 1) = d.Item(k) Then      [/INDENT]
[INDENT=4]                               Set newtempsearchrange = Range(XXXXXXXXX)  [B] 'I am unable to set a new search range from Name to the end of the project list[/B][/INDENT]
[INDENT=4]                                    d2.RemoveAll[/INDENT]
[INDENT=4]                                    For Each cell2 In newtempsearchrange        'Creates the dictionary that will contain the projects (as Key) an employ already has[/INDENT]
[INDENT=4]                                        DoEvents[/INDENT]
[INDENT=4]                                        k2 = cell2.Text[/INDENT]
[INDENT=4]                                        d2.Add k2, v2[/INDENT]
[INDENT=4]                                        v2 = v2 + 1[/INDENT]
[INDENT=4]                                    Next cell2[/INDENT]
[INDENT=4]                            If (Not (d2.Exists(k))) Then                               [B]'Check if Project from Sheet1 is in the dicitonary of projects from a Name[/B][/INDENT]
[INDENT=4]                                XXXXX.End(xlDown).EntireRow.Offset(1).Insert [B]'I cannot insert a row after the Projects under a Name[/B][/INDENT]
[INDENT=4]                                XXXXX.End(xlDown).Offset(1).Value = k[/INDENT]
[INDENT=4]                                d.Remove (k)[/INDENT]
[INDENT=4]                                Set d = Nothing[/INDENT]
[INDENT=4]                            End If[/INDENT]
[INDENT=4]                           End If[/INDENT]
[INDENT=4]                        Next ii[/INDENT]
[INDENT=4]            End If[/INDENT]
[INDENT=4]            Worksheets("Sheet1").Activate[/INDENT]
[INDENT=4]            Set d2 = Nothing[/INDENT]
[INDENT=4]        Next j[/INDENT]
[INDENT=4]    Next i[/INDENT]
[INDENT=4]End Sub

​