Sub MergeStuff2()
Dim arP, arT, arD
Dim i As Integer, ii As Integer, iii As Integer
Dim Dict
Dim wsP As Worksheet, wsT As Worksheet, wsD As Worksheet, wsR As Worksheet
Dim wsTnP As Worksheet, wsDnP As Worksheet
Dim sIDName As String, sID As String
Dim sTemp As String, sAssign As String
Const shPROJECT As String = "Projects"
Const shTASKS As String = "Tasks"
Const shDETAILS As String = "Details"
Const shTnPROJECTS As String = "In_Tasks_but_NOT_in_Projects"
Const shDnPROJECTS As String = "In_Details_but_NOT_in_Projects"
Set wsP = Worksheets(shPROJECT)
Set wsT = Worksheets(shTASKS)
Set wsD = Worksheets(shDETAILS)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "RESULT_" & Replace(Time, ":", ",")
Set wsR = ActiveSheet
Set wsTnP = Worksheets(shTnPROJECTS)
Set wsDnP = Worksheets(shDnPROJECTS)
Set Dict = CreateObject("Scripting.Dictionary")
'Add empty columns in tabs for copy paste (will be removed at the end)
With wsP
.Columns(3).Insert
.Range("C1") = "XXX"
End With
With wsT
.Columns(4).Insert
.Range("D1") = "xxx"
End With
With wsD
.Columns(2).Insert
.Columns(4).Insert
.Columns(4).Insert
.Range("B1") = "XXX"
End With
With wsDnP
.Columns(2).Insert
.Columns(4).Insert
.Columns(4).Insert
End With
wsTnP.Columns(4).Insert
'Store values of the different tabs for faster loops
arP = wsP.Cells(1).CurrentRegion.Value
arT = wsT.Cells(1).CurrentRegion.Value
arD = wsD.Cells(1).CurrentRegion.Value
'Create a dictionary of project ID from Project Tab
For i = 2 To UBound(arP, 1)
If Not Dict.exists(arP(i, 1)) Then Dict.Add arP(i, 1), arP(i, 1)
Next i
'We loop through each Project ID
' For each we then check in the Tasks tab if exists or not
' And we then check in the Details tab for a match on ID and Name
For i = 2 To UBound(arP, 1)
sID = arP(i, 1)
wsP.Rows(i).Copy wsR.Range("A60000").End(xlUp).Offset(1, 0) 'Copy project in results tab
'Check in Tasks (loop through all values)
For ii = 2 To UBound(arT, 1)
'if not in dictionary then copy to Task not in project tab
If arT(ii, 1) <> "_DONE_" Then
If Not Dict.exists(arT(ii, 1)) Then
wsT.Rows(ii).Copy wsTnP.Range("A60000").End(xlUp).Offset(1, 0)
arT(ii, 1) = "_DONE_" 'Mark as done to not process an other time
'it exists in the dictionary
Else
sIDName = arT(ii, 1) & "|" & arT(ii, 2) 'To match in Details tab
If sID = arT(ii, 1) Then
wsT.Rows(ii).Copy wsR.Range("A60000").End(xlUp).Offset(1, 0) 'Copy
'Swap values
With wsR.Range("A60000").End(xlUp)
sAssign = .Offset(0, 1)
.Offset(0, 1) = .Offset(0, 2)
.Offset(0, 2) = sAssign
End With
arT(ii, 1) = "_DONE_"
End If
'Check in details
For iii = 2 To UBound(arD, 1)
If arD(iii, 1) <> "_DONE_" Then
'does not exists
If Not Dict.exists(arD(iii, 1)) Then
wsD.Rows(iii).Copy wsDnP.Range("A60000").End(xlUp).Offset(1, 0)
arD(iii, 1) = "_DONE_"
'Exists, check if we have match on ID and name
Else
sTemp = arD(iii, 1) & "|" & arD(iii, 3)
If sTemp = sIDName And arD(iii, 1) = sID Then
wsD.Rows(iii).Copy wsR.Range("A60000").End(xlUp).Offset(1, 0)
arD(iii, 1) = "_DONE_"
End If
End If
End If
Next iii
End If
End If
Next ii
'Now that we have loop through all rows of task we can identify the Mismatch
' ie : same ID but different name
For iii = 2 To UBound(arD, 1)
If arD(iii, 1) = sID Then
wsD.Rows(iii).Copy wsR.Range("A60000").End(xlUp).Offset(1, 0)
wsR.Range("A60000").End(xlUp).Offset(0, 4) = "MISMATCH"
arD(iii, 1) = "_DONE_"
End If
Next iii
Next i
'Delete added column in Details
wsP.Columns(3).EntireColumn.Delete
wsT.Columns(4).EntireColumn.Delete
With wsD
.Columns(5).EntireColumn.Delete
.Columns(4).EntireColumn.Delete
.Columns(2).EntireColumn.Delete
End With
With wsDnP
.Columns(5).EntireColumn.Delete
.Columns(4).EntireColumn.Delete
.Columns(2).EntireColumn.Delete
End With
wsTnP.Columns(4).EntireColumn.Delete
'Add Headers
With wsR.Cells(1).Resize(1, 10)
.Value = Array("ID", "Assignment", "Name", "Allotted Hours", _
"Total Billed", "Hours", "Area", "Pending", "StartDate", "FinishDate")
.Interior.ColorIndex = 49
.Font.ColorIndex = 2
.CurrentRegion.Columns.AutoFit
End With
End Sub
LinkBack URL
About LinkBacks
desibabuji 
Register To Reply
Bookmarks