Sub MergeData()
Const sShEngineer As String = "Database_Engineer"
Const sShPlanner As String = "Data_Planner"
Const sShResult As String = "Result_VBA"
Dim oDic As Object, aEngineer As Variant, aPlanner As Variant
aEngineer = Sheets(sShEngineer).Range("C3:AV" & CStr(Sheets(sShEngineer).Cells(&H100000, "D").End(xlUp).Row + 1)).Value
Set oDic = InitializeDic(aEngineer)
aPlanner = Sheets(sShPlanner).Range("A3:H" & CStr(Sheets(sShPlanner).Cells(&H100000, "A").End(xlUp).Row + 1)).Value2
Dim i As Long, ii As Long, j As Long, k As Long, aResult As Variant, u1 As Long, u2 As Long, aTmp As Variant
u1 = UBound(aPlanner, 2)
u2 = UBound(aEngineer, 2)
ReDim aResult(1 To 10000, 1 To u1 + u2 - 1)
For i = 1 To UBound(aPlanner) - 1
If oDic.Exists(aPlanner(i, 3)) Then
aTmp = oDic.Item(aPlanner(i, 3))
ElseIf oDic.Exists("_" & aPlanner(i, 3)) Then
aTmp = oDic.Item("_" & aPlanner(i, 3))
Else
k = k + 1
For j = 1 To u1
aResult(k, j) = aPlanner(i, j)
Next
GoTo Next_i
End If
For ii = aTmp(0) To aTmp(1)
k = k + 1
For j = 1 To u1
aResult(k, j) = aPlanner(i, j)
Next
For j = 2 To u2
aResult(k, u1 - 1 + j) = aEngineer(ii, j)
Next
Next
Next_i:
Next
Sheets(sShResult).UsedRange.Offset(3).Clear
Sheets(sShResult).Range("A3").Resize(, UBound(aResult, 2) + 1).ClearContents
If k > 0 Then
Sheets(sShResult).Range("A3").Resize(k, UBound(aResult, 2) + 2).FillDown
Sheets(sShResult).Range("A3").Resize(k, UBound(aResult, 2)).Value2 = aResult
End If
End Sub
Private Function InitializeDic(ByRef aEngineer As Variant) As Object
Dim i As Long, k As Long
Set InitializeDic = CreateObject("Scripting.Dictionary")
k = 1
For i = 1 To UBound(aEngineer, 1) - 1
If aEngineer(i, 1) <> aEngineer(i + 1, 1) Then
InitializeDic.Item(aEngineer(i, 1)) = Array(k, i)
k = i + 1
ElseIf aEngineer(i, 1) = "" And aEngineer(i, 2) <> aEngineer(i + 1, 2) Then
InitializeDic.Item("_" & aEngineer(i, 2)) = Array(k, i)
k = i + 1
End If
Next
End Function
