Merge or combine data and tables with Excel VBA macros

Sub MergeLists()
'Merges two lists into one without
'duplicates. The merged list is inserted
'into a new workbook and sorted.
Dim rA As Range                  'The first list
Dim rB As Range                  'The second list
Dim rCell As Range               'Range variable
Dim lCount As Long               'Counter
Dim colMerge As New Collection   'Collection

On Error GoTo ErrorHandle

'Switch off screen updating for speed
Application.ScreenUpdating = False

'Sets the two ranges for the lists. Here they
'have only one column, but several columns
'would make no difference.
Worksheets(1).Activate
Set rA = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(2).Activate
Set rB = Range(Range("A1"), Range("A1").End(xlDown))

'Now we add all values to our collection. By adding
'each value as key we avoid duplicates. If a
'duplicate value is added as key, it triggers an
'error, and that is why we write:
On Error Resume Next

For Each rCell In rA
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rB
   colMerge.Add rCell.Value, rCell.Value
Next

On Error GoTo ErrorHandle

'Make a new workbook
Workbooks.Add

'Insert the merged list with unique values:
With colMerge
   For lCount = 1 To .Count
      Range("A1").Offset(lCount - 1).Value = .Item(lCount)
   Next
End With

'The list is defined as a range
Set rA = Range(Range("A1"), Range("A1").End(xlDown))

'and sorted ascending (default). If this code for sorting
'doesn't work with your Excel version then change it -
'e.g. by using the macro recorder.
rA.Sort Key1:=Range("A1")

BeforeExit:
Set rA = Nothing
Set rB = Nothing
Set rCell = Nothing
Set colMerge = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure MergeLists"
Resume BeforeExit
End Sub

Sub UniqueAndDuplicates()
'Loops two tables/lists and makes two new tables.
'The first table contains values that are in both
'original tables, and the other contains values,
'that are NOT in both original tables.
'To check for duplicate values we use the
'worksheet function "CountIf".
Dim rA As Range      'Table1 1
Dim rB As Range      'Table 2
Dim rCell As Range   'Range variable
Dim vResult()        'Array for non duplicates
Dim vResult2()       'Array for duplicates
Dim lCount As Long   'Counter
Dim lCount2 As Long  'Counter

On Error GoTo ErrorHandle

Application.ScreenUpdating = False

ThisWorkbook.Worksheets(1).Activate

'In this example we take for granted that there
'is a table starting in column A. Any proper
'code should of course check this, but I am lazy.

Set rA = Range(Range("A1"), Range("A1").End(xlDown))
Set rB = Worksheets(2).Range("A1")
Set rB = Range(rB, rB.End(xlDown))

'The values will be stored in two arrays that will
'be copied to the spreadsheet in one swift
'operation. At this point in time we don't know
'how many values we will find, so we just dimension
'the arrays to have as many rows as the two
'ranges combined.
ReDim vResult(1 To rA.Count + rB.Count, 1 To 1)
ReDim vResult2(1 To rA.Count + rB.Count, 1 To 1)

'We now loop through the two ranges, and for
'each cell we check if the value is in the
'other range. We do this using the worksheet
'function "CountIf".
For Each rCell In rA
   With rCell
      If WorksheetFunction.CountIf(rB, .Value) = 0 Then
         lCount = lCount + 1
         vResult(lCount, 1) = .Value
      Else
         lCount2 = lCount2 + 1
         vResult2(lCount2, 1) = .Value
      End If
   End With
Next
For Each rCell In rB
   With rCell
      If WorksheetFunction.CountIf(rA, .Value) = 0 Then
         lCount = lCount + 1
         vResult(lCount, 1) = .Value
      Else
         lCount2 = lCount2 + 1
         vResult2(lCount2, 1) = .Value
      End If
   End With
Next

'If there were any unique values
If lCount > 0 Then
   'We insert the new table in column J
   'on the sheet "Table 1". Before doing so we
   'define a range with the same dimensions as
   'the array. This allows us to copy in one
   'swift operation instead of looping through
   'the arrays.
   Set rCell = Range("J2").Resize(UBound(vResult), 1)
   rCell.Value = vResult()
   With Range("J1")
      .Value = "Unique:"
      .Font.Bold = True
   End With
Else
   MsgBox "All values are present in both tables."
End If

'If there were any duplicates
If lCount2 > 0 Then
   Set rCell = Range("K2").Resize(UBound(vResult2), 1)
   rCell.Value = vResult2()
   With Range("K1")
      .Value = "Duplicates:"
      .Font.Bold = True
   End With
Else
   MsgBox "There were no duplicate values."
End If

BeforeExit:
Set rA = Nothing
Set rB = Nothing
Set rCell = Nothing
Erase vResult
Erase vResult2
Application.ScreenUpdating = True
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure UniqueAndDuplicates"
End Sub

Option Explicit
Dim bAbort As Boolean
Dim sWbName As String

'***

Sub CombineTables()
'Top macro

'Switch off screen updating
Application.ScreenUpdating = False

CheckCompanyList  'Procedure call
If bAbort = True Then GoTo BeforeExit
Combine  'Procedure call

BeforeExit:
Application.ScreenUpdating = True
bAbort = False
End Sub

'***

Sub CheckCompanyList()
'Checks if the company list workbook exists
'and opens it if not already opened.
Dim wb As Workbook   'Workbook variable
Dim sPath As String  'String variable

On Error Resume Next

'Reads file name and path
With Worksheets("Macro")
   sPath = .Range("B1").Value
   If Len(sPath) > 4 Then
      sWbName = sPath
   Else
      MsgBox sPath & " is not a valid file name."
      bAbort = True
      GoTo BeforeExit
   End If
   'Concatenates path and file name
   sPath = .Range("B2").Value & sWbName
   If Len(sPath) < 8 Then
      MsgBox sPath & " is not a valid path."
      bAbort = True
      GoTo BeforeExit
   End If
End With

'Checks if the file is in the folder
If Len(Dir(sPath)) = 0 Then
   MsgBox "The company list workbook is not in the said folder."
   bAbort = True
   GoTo BeforeExit
End If

'Opens the company table if not open already.
Set wb = Workbooks(sWbName)
If wb Is Nothing Then
   Workbooks.Open (sPath)
End If

BeforeExit:
Set wb = Nothing

End Sub

'***

Sub Combine()
'Combines the company and contacts lists and
'inserts the new table into a new workbook.
Dim rPersons As Range   'Range for the persons list
Dim rCompanies As Range 'Range for the company list
Dim colCompanies As New Collection 'Collection for company names
Dim vContacts()         'Array for contacts
Dim vPersons()          'Array for persons
Dim vResult()           'The result array
Dim lCol As Long        'Columns counter
Dim lMax As Long        'Max number of contacts 1 company
Dim lCount As Long      'Counter
Dim lCount2 As Long     'Counter
Dim lCount3 As Long     'Counter
Dim lPcount As Long     'Counter
Dim lLast As Long       'Column Counter
Dim lHits As Long       'Counter
Dim dFound As Double    'Counter
Dim lResultCol As Long  'Number of columns in result array
Dim lResultRows As Long 'Number of rows -

On Error GoTo ErrorHandle

ThisWorkbook.Worksheets("Persons").Activate

'Checks the contacts list
If IsEmpty(Range("A2")) Then
   MsgBox "First cell in contacts list is empty."
   bAbort = True
   Exit Sub
End If

'Sets the persons range
If Len(Range("A3")) > 0 Then
   Set rPersons = Range(Range("A2"), Range("A2").End(xlDown))
   Set rPersons = Range(rPersons, rPersons.Offset(0, 3))
Else
   Set rPersons = Range(Range("A2"), Range("A2").Offset(0, 3))
End If

'The persons range is copied to an array for speed.
vPersons() = rPersons.Value

Workbooks(sWbName).Worksheets("Companies").Activate

'Checks the company list
If IsEmpty(Range("A2")) Then
   MsgBox "First cell in company list is empty."
   bAbort = True
   Exit Sub
End If

'Sets the range for companies
If Len(Range("A3")) > 0 Then
   Set rCompanies = Range(Range("A2"), Range("A2").End(xlDown))
   Set rCompanies = Range(rCompanies, rCompanies.Offset(0, 5))
Else
   Set rCompanies = Range(Range("A2"), Range("A2").Offset(0, 5))
End If

'Copies the range to an array for speed
With rCompanies
   vResult() = .Value
   lResultCol = .Columns.Count   'Saves number of columns
   lResultRows = .Rows.Count     'Saves number of rows
End With

'Sets the company range to nothing to save memory
Set rCompanies = Nothing

'By adding company names as keys to a collection, we get
'a list with no duplicates. If a name already in the
'collection is added once more it triggers an error, and
'that is the reason for the next line.
On Error Resume Next

For lCount = 1 To UBound(vResult)
   colCompanies.Add vResult(lCount, 1), vResult(lCount, 1)
Next

On Error GoTo ErrorHandle

'We now loop the collection with unique company names.
'For each company name we loop the persons list, and
'all contacts for the company are added to the array,
'vContacts with 3 columns for name, tel. and e-mail.
With colCompanies
   'The outer loop for company names
   For lCount = 1 To .Count
      'Columns counter is reset
      lLast = 0
      'The worksheet function CountIf finds how many
      'times the company name is in the persons list.
      dFound = _
      WorksheetFunction.CountIf(rPersons.Columns(2), .Item(lCount))
      If dFound > 0 Then
         lCol = dFound * 3
         'vContacts is re-dimensioned to number of instances times
         '3 (name, tel. and e-mail).
         ReDim vContacts(1 To 1, 1 To lCol)
         'lMax saves the highest number of contacts * 3.
         'This is used later to dimension the result array.
         If lCol > lMax Then lMax = lCol
         'Loops through the persons list to find the contacts
         For lPcount = 1 To UBound(vPersons)
            'If we find the company name
            If vPersons(lPcount, 2) = .Item(lCount) Then
               lHits = lHits + 1
               'We save the contact's name, tel. and e-mail
               vContacts(1, lLast + 1) = vPersons(lPcount, 1)
               vContacts(1, lLast + 2) = vPersons(lPcount, 3)
               vContacts(1, lLast + 3) = vPersons(lPcount, 4)
               lLast = lHits * 3
            End If
         Next
      End If
      'If the company name was found in the persons list
      If dFound > 0 Then
         'If necessary we re-dimension the result array
         If lResultCol < 6 + lMax Then
            lResultCol = 6 + lMax
            ReDim Preserve vResult(1 To lResultRows, 1 To lResultCol)
         End If
         'We loop the company list to find the company name
         For lCount2 = 1 To UBound(vResult)
            'Where found the contact person(s) is added
            If vResult(lCount2, 1) = .Item(lCount) Then
               'We now loop vContacts from left to right and
               'insert the contact info into the result array.
               For lCount3 = 1 To lCol
                  vResult(lCount2, 6 + lCount3) = vContacts(1, lCount3)
               Next
            End If
         Next
      End If
      lHits = 0   'lHits is reset
   Next
End With

'Add new workbook
Workbooks.Add
'Make it the active sheet
Workbooks(Workbooks.Count).Worksheets(1).Activate

'On sheet 1 we set a range with the same
'dimensions as the result array.
Set rPersons = Range(Range("A2"), Range("A2").Offset(lResultCol))
Set rPersons = rPersons.Resize(lResultRows, lResultCol)
'The table (the result array) is inserted in one swift operation:
rPersons.Value = vResult()

'The following just formats the look of the table.
'First row:
Set rCompanies = _
Range(Range("A1"), Range("A1").Offset(0, lResultCol - 1))
With rCompanies
   .Interior.Color = 12688476
   .Font.Bold = True
   .Font.ColorIndex = 2
   .Item(1).Value = "Company"
   .Item(2).Value = "Address"
   .Item(3).Value = "Postal code"
   .Item(4).Value = "City"
   .Item(5).Value = "Type"
   .Item(6).Value = "Info"
   For lCount = 7 To lResultCol
      lHits = lCount Mod 3
      Select Case lHits
         Case 1
            .Item(lCount).Value = "Contacts"
         Case 2
            .Item(lCount).Value = "Tel."
         Case 0
            .Item(lCount).Value = "E-mail"
      End Select
   Next
End With

'Every second row in the table gets a background colour.
With rPersons
   For lCount = 1 To lResultRows Step 2
      If lCount > lResultRows Then Exit For
      .Rows(lCount).Interior.Color = 15000804
   Next
End With

Set rCompanies = rCompanies.Resize(lResultRows + 1)
With rCompanies
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
    End With
    With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
    End With
    With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
    End With
    With .Borders(xlEdgeRight)
        .LineStyle = xlContinuous
    End With
    With .Borders(xlInsideVertical)
        .LineStyle = xlContinuous
    End With
    With .Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
    End With
    .Columns.AutoFit
End With
   
BeforeExit:
Set rPersons = Nothing
Set rCompanies = Nothing
Set colCompanies = Nothing
Erase vResult
Erase vPersons
Erase vContacts
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure Combine"
bAbort = True
End Sub