在Excel中使用VBA合併兩個表

Question

使用Excel VBA我希望能夠將excel中的兩個表與一個公共密鑰相結合。我建議將ADODB作爲一種方法，但我願意接受任何其他更高效/優雅的方法。請參閱下面的一個小例子：

我有下面下手......

工作表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 

，並想它結合，從而我有以下結果：

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 

已經做了一點Google搜索和SQL類型外連接似乎接近但不知道如何實現它。

下面是用於嘗試並實施至今的代碼...

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 

Answer 1

取決於你是否有任何紙張上重複的值，我能想到的一些想法，而不是使用SQL雖然。

• 獲取SourceSheet1 &的LASTROW SourceSheet2 - 將它們設置爲變量lastRow1 & lastRow2
• 爲每個表的行股票。 s1Row，s2Row，tRow
• set tRow = 2對於TargetSheet的第一行
• 使用For循環遍歷SourceSheet1的每一行。使用類似這樣的代碼
• 當代碼的第一部分完成循環時，您將完成將SourceSheet1中的每個項目添加到TargetSheet中。然後，你將不得不檢查SourceSheet2中的值，看看是否有唯一的列表。
• 完成後，您應該只添加最初搜索時丟失的那些。然後targetSheet將在SourceSheet1的訂單的所有項目，然後從SourceSheet2額外的項目

設置變量

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：複製從Sheet1中的每個條目到目標，而從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 

第二階段：工作表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 

01檢查SourceSheet2接受報名NOT

編輯：錯字改正試過現在又增加了