Reputation: 13485
Using Excel VBA I would like to be able to combine two tables in excel with a common key. I have suggested ADODB as a method,but am open to any other more efficient/elegant methods. Please see below for a minimal example:
I have the below to start with...
Sheet1
A B C
1 type year1 year2
2 aaa 100 110
3 bbb 220 240
4 ccc 304 200
5 ddd 20 30
6 eee 440 20
Sheet2
A B C
1 type year1 year2
2 bbb 10 76
3 ccc 44 39
4 ddd 50 29
5 eee 22 23
6 fff 45 55
And would like to combine it so that I have the following as a result:
Sheet3
A B C D E
1 type year1 year2 year1 year2
2 aaa 100 110 0 0
3 bbb 220 240 10 76
4 ccc 304 200 44 39
5 ddd 20 30 50 29
6 eee 440 20 22 23
7 fff 0 0 45 55
Have done a bit of googling and SQL type outer joins seems close but not sure how to implement it.
Below is the code used to try and implement it so far...
Option Explicit
Sub JoinTables()
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
With cn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties=Excel 8.0;"
.Open
End With
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
rs.Open "SELECT * FROM [Sheet1$] OUTER JOIN [Sheet2$] ON [Sheet1$].[type] = " & _
"[Sheet2$].[type]", cn
With Worksheets("Sheet3")
.Cells(2, 1).CopyFromRecordset rs
End With
rs.Close
cn.Close
End Sub
Upvotes: 1
Views: 18959
Reputation: 2477
Depending on whether or not you have duplicate values on either sheet, I could think of a few ideas, not using SQL though.
SET VARIABLES
Private Sub JoinLists()
Dim rng As Range
Dim typeName As String
Dim matchCount As Integer
Dim s1Row As Integer
Dim s2Row As Integer
Dim tRow As Integer
Dim m As Integer
Dim lastRow1 As Integer
Dim lastRow2 As Integer
Dim SourceSheet1 As String
Dim SourceSheet2 As String
Dim TargetSheet As String
SourceSheet1 = "Source1"
SourceSheet2 = "Source2"
TargetSheet = "Target"
tRow = 2
lastRow1 = Sheets(SourceSheet1).Range("A65536").End(xlUp).row
lastRow2 = Sheets(SourceSheet2).Range("A65536").End(xlUp).row
PHASE ONE: Copying every entry from Sheet1 to Target, while grabbing matches from Sheet2
Set rng = Sheets(SourceSheet2).Range("A2:A" & lastRow2)
For s1Row = 2 To lastRow1
typeName = Sheets(SourceSheet1).Cells(s1Row, 1)
matchCount = Application.WorksheetFunction.CountIf(rng, typeName)
'Set the Row up on the TargetSheet. No matter if it's a match.
Sheets(TargetSheet).Cells(tRow, 1) = typeName
Sheets(TargetSheet).Cells(tRow, 2) = Sheets(SourceSheet1).Cells(s1Row, 2)
Sheets(TargetSheet).Cells(tRow, 3) = Sheets(SourceSheet1).Cells(s1Row, 3)
'Check to see if there are any matches on SourceSheet2
If matchCount = 0 Then
'There are NO matches. Add Zeros to the extra columns
Sheets(TargetSheet).Cells(tRow, 4) = 0
Sheets(TargetSheet).Cells(tRow, 5) = 0
Else
'Get first matching occurance on the SourceSheet2
m = Application.WorksheetFunction.Match(typeName, rng, 0)
'Get Absolute Row number of that match
s2Row = m + 1 ' This takes into account the Header Row, as index 1 is Row 2 of the search Range
'Set the extra columns on TargetSheet to the Matches on SourceSheet2
Sheets(TargetSheet).Cells(tRow, 4) = Sheets(SourceSheet1).Cells(s2Row, 2)
Sheets(TargetSheet).Cells(tRow, 5) = Sheets(SourceSheet1).Cells(s2Row, 3)
End If
tRow = tRow + 1
Next s1Row
PHASE TWO: Checking SourceSheet2 for Entries NOT on Sheet1
Set rng = Sheets(SourceSheet1).Range("A2:A" & lastRow1)
For s2Row = 2 To lastRow2
typeName = Sheets(SourceSheet2).Cells(s2Row, 1)
matchCount = Application.WorksheetFunction.CountIf(rng, typeName)
If matchCount = 0 Then
'There are NO matches. Add to Target Sheet
Sheets(TargetSheet).Cells(tRow, 1) = typeName
Sheets(TargetSheet).Cells(tRow, 2) = 0
Sheets(TargetSheet).Cells(tRow, 3) = 0
Sheets(TargetSheet).Cells(tRow, 4) = Sheets(SourceSheet2).Cells(s2Row, 2)
Sheets(TargetSheet).Cells(tRow, 5) = Sheets(SourceSheet2).Cells(s2Row, 3)
tRow = tRow + 1
'Not doing anything for the matches, because they were already added.
End If
Next s2Row
End Sub
EDIT: typo correction
Upvotes: 2