Copy data from 2 sheets into a single sheet in interleaving format

Question

I have 2 sets of data in 2 sheets having same columns in each sheet. I want to copy both the sets of data from 2 sheets into a 3rd sheet but in the following format:-

Sheet1
Name Age Gender
Mayur 23  M
Alex  24  M
Maria 25  F
April 19  F

Sheet2
Name Age Gender
Mayur 21  M
Maria 24  F
Alex  24  M
June  20  F


Sheet3
Name1 Name2 Age1 Age2 Gender1 Gender2
Mayur Mayur  23   21     M       M
Alex  Alex   24   24     M       M
Maria Maria  25   24     F       F
April        19          F 
      June        20             F

Now there is one primary column i.e. Name. This column will never be empty. Both the sheets may not have the data in the same sequence. Both the sheets may have different entries for the same name. There could be a name missing in any of the sheets

I have written the whole code which does the following:-

I find out Names from sheet1 in sheet2 & then copy corresponding entries for that name from both the sheets to sheet3.

If a name is not found in sheet2 then it's data is copied as it is as shown above & finally Names in sheet2 are searched in sheet1 if any name is not present in there those entries are copied in sheet3.

Now the searching part runs quite well performance wise but the copying part takes a lot of time.

I have tried other methods of copying the data as well but none runs quite fast. In actual data there are more than 200 columns & millions of rows. The whole process runs for more than 6-7 hours.

Could anyone please let me know any alternative faster way of achieving this. Even if that could reduce the time to an hour or 2 from 7 hours that's still great.

Also I need to highlight the descrepancies which I'm doing that by changing the cell color when there is a mismatch in the data while copying from both the sheets.

Below is the code

Sub findUsingArray()
Dim i As Long
Dim j As Variant
Dim noOfColumnsA As Integer
Dim maxNoOfColumns As Integer
Dim noOfRowsA As Long
Dim noOfRowsB As Long
Dim arrayColumnA() As Variant
Dim arrayColumnB() As Variant
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Dim primaryKeyColumn As Integer
Dim result As Long

Set sheet1 = ThisWorkbook.Sheets("Sheet1")
Set sheet2 = ThisWorkbook.Sheets("Sheet2")

noOfColumnsA = sheet1.Cells(1, Columns.Count).End(xlToLeft).Column

maxNoOfColumns = noOfColumnsA * 2

noOfRowsA = sheet1.Cells(Rows.Count, 1).End(xlUp).Row

noOfRowsB = sheet2.Cells(Rows.Count, 1).End(xlUp).Row

'createHeader maxNoOfColumns Used to create header in 3rd sheet

primaryKeyColumn = 1

ReDim arrayColumnA(noOfRowsA)
ReDim arrayColumnB(noOfRowsB)


arrayColumnA = sheet1.Range(sheet1.Cells(1, primaryKeyColumn), sheet1.Cells(noOfRowsA, primaryKeyColumn))

arrayColumnB = sheet2.Range(sheet2.Cells(1, primaryKeyColumn), sheet2.Cells(noOfRowsB, primaryKeyColumn))


    result = 2

        For i = 2 To noOfRowsA
            j = Application.Match(arrayColumnA(i, 1), sheet2.Range(sheet2.Cells(1, primaryKeyColumn), sheet2.Cells(noOfRowsB, primaryKeyColumn)), 0)

                If Not IsError(j) Then
                    result = copyInaRowUsingArray(i, result, j, maxNoOfColumns)
                Else
                    result = copyMissingRow(1, i, result, maxNoOfColumns)
                End If
        Next i

    For i = 2 To noOfRowsB
        j = Application.Match(arrayColumnB(i, 1), sheet1.Range(sheet1.Cells(1, primaryKeyColumn), sheet1.Cells(noOfRowsA, primaryKeyColumn)), 0)

        If IsError(j) Then
            result = copyMissingRow(2, i, result, maxNoOfColumns)
        End If

    Next i
End Sub

Function copyInaRowUsingArray(sheet1Index As Long, newRowIndex As Long, sheet2index As Variant, noOfColumns As Integer)
Dim i As Long
Dim j As Long
Dim val As Variant
Dim valueA As String
Dim valueB As String
Dim arrayA() As Variant
Dim arrayB() As Variant
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Dim sheet3 As Worksheet
Dim rowColoured As Boolean

j = 1

Set sheet1 = ThisWorkbook.Sheets("Sheet1")
Set sheet2 = ThisWorkbook.Sheets("Sheet2")
Set sheet3 = ThisWorkbook.Sheets("Sheet3")


 arrayA = Application.Transpose(Application.Transpose(sheet1.Range(sheet1.Cells(sheet1Index, 1), sheet1.Cells(sheet1Index, noOfColumns)).Value))
 arrayB = Application.Transpose(Application.Transpose(sheet2.Range(sheet2.Cells(sheet2index, 1), sheet2.Cells(sheet2index, noOfColumns)).Value))

 rowColoured = False

With sheet3

    For i = 1 To noOfColumns

        valueA = arrayA(j)
        If Not valueA = "" Then
            .Cells(newRowIndex, i).Value = valueA
        End If
        i = i + 1

        valueB = arrayB(j)
        If Not valueB = "" Then
            .Cells(newRowIndex, i).Value = valueB
        End If

        If Not StrComp(CStr(valueA), CStr(valueB)) = 0 Then
            If Not rowColoured Then
                .Range(.Cells(newRowIndex, 1), .Cells(newRowIndex, noOfColumns)).Interior.ColorIndex = 35
                rowColoured = True
            End If

            .Cells(newRowIndex, i).Interior.ColorIndex = 34
            .Cells(newRowIndex, i - 1).Interior.ColorIndex = 34
        End If

        j = j + 1

    Next i

    copyInaRowUsingArray = newRowIndex + 1
End With
End Function

Function copyMissingRow(sheetNo As Integer, sheetIndex As Long, newRowIndex As Long, noOfColumns As Integer)

Dim i As Long
Dim j As Long
Dim val As Variant
Dim valueA As String
Dim valueB As String
Dim arrayA() As Variant
Dim arrayB() As Variant
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Dim sheet3 As Worksheet

j = 1

Set sheet3 = ThisWorkbook.Sheets("Sheet3")

With sheet3
    If sheetNo = 1 Then
        Set sheet1 = ThisWorkbook.Sheets("Sheet1")

        ReDim arrayA(noOfColumns)
        arrayA = Application.Transpose(Application.Transpose(sheet1.Range(sheet1.Cells(sheetIndex, 1), sheet1.Cells(sheetIndex, noOfColumns)).Value))

        For i = 1 To noOfColumns

            valueA = arrayA(j)
            If Not valueA = "" Then
                .Cells(newRowIndex, i).Value = valueA
            End If
            i = i + 1
            j = j + 1

        Next i

        .Range(.Cells(newRowIndex, 1), .Cells(newRowIndex, noOfColumns)).Interior.ColorIndex = 46

    Else

        Set sheet2 = ThisWorkbook.Sheets("Sheet2")

        ReDim arrayB(noOfColumns)
        arrayB = Application.Transpose(Application.Transpose(sheet2.Range(sheet2.Cells(sheetIndex, 1), sheet2.Cells(sheetIndex, noOfColumns)).Value))

        For i = 1 To noOfColumns

            i = i + 1

            valueB = arrayB(j)
            If Not valueB = "" Then
                .Cells(newRowIndex, i).Value = valueB
            End If

            j = j + 1

        Next i

        .Range(.Cells(newRowIndex, 1), .Cells(newRowIndex, noOfColumns)).Interior.ColorIndex = 3

    End If

     copyMissingRow = newRowIndex + 1

End With
End Function

Answer 1

As per one of the comments, a dictionary should help do what it is you're after. The dictionary used here saves, from sheet(2), the name as the key and the corresponding row as the value.

Option Explicit

Sub CopyRng(frmSht As Worksheet, frmRow As Integer, offset As Integer, toRow As Integer)
  Dim r As Integer
  For r = 1 To 3:
    Sheets(3).Cells(toRow, offset + 2 * r).Value = frmSht.Cells(frmRow, r).Value
  Next
End Sub


Sub InterleaveRows()  
  Dim dict As Object
  Set dict = CreateObject("Scripting.Dictionary")

  With Sheets(2)
    Dim r As Integer, r2 As Integer, r3 As Integer: r3 = 2
    Dim val As String
    For r = 2 To .Range("A" & .Rows.Count).End(xlUp).row:
      dict(.Cells(r, "A").Value) = r
    Next
  End With

  CopyRng Sheets(1), 1, -1, 1
  CopyRng Sheets(2), 1, 0, 1

  For r = 2 To Sheets(1).Range("A" & Sheets(1).Rows.Count).End(xlUp).row:
    val = Sheets(1).Cells(r, "A").Value
    If (dict.Exists(val)) Then
      r2 = dict(val)
      CopyRng Sheets(1), r, -1, r3
      CopyRng Sheets(2), r2, 0, r3
      dict.Remove val
    Else
      CopyRng Sheets(1), r, -1, r3
    End If
    r3 = r3 + 1
  Next

  For r = 0 To dict.Count - 1
    r2 = dict.items()(r)
    CopyRng Sheets(2), r2, 0, r3
    r3 = r3 + 1
  Next

End Sub

The first loop of the 'InterLeaveRows' subroutine populates the dictionary by going through all the entries in Sheet(2). The next two lines writes out the header to sheet(3). The 2nd loop then writes out all values to Sheet(3) that are either in the dictionary (ie in both Sheet(1) and Sheet(2)) or just in Sheet(1); note while doing so entries from the dictionary that are written to Sheet(3) are deleted from the dictionary. The last loop writes out key/val pairs that remain in the dictionary. These are entries that are only in Sheet(2).