vba 使用VBA在Excel中组合两个表
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/26673792/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Combining two tables in Excel using VBA
提问by h.l.m
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:
使用 Excel VBA，我希望能够将 excel 中的两个表与一个公共键组合在一起。我建议将 ADODB 作为一种方法，但我对任何其他更有效/更优雅的方法持开放态度。请参阅下面的最小示例：
I have the below to start with...
我有以下开始...
Sheet1
表 1
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
表 2
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
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.
已经做了一些谷歌搜索和 SQL 类型的外连接似乎很接近但不确定如何实现它。
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
回答by peege
Depending on whether or not you have duplicate values on either sheet, I could think of a few ideas, not using SQL though.
根据您在任一工作表上是否有重复值，我可以想到一些想法，但不使用 SQL。
- Get LastRow of SourceSheet1 & SourceSheet2 - Set them as variables lastRow1 & lastRow2
- Create a row ticker for each sheet. s1Row, s2Row, tRow
- set tRow = 2 For the TargetSheet's first line
- Use For loop to cycle through each row of SourceSheet1. Using something like this
- When the first part of code is done looping, you will be finished adding every item from SourceSheet1 onto the TargetSheet. Then you will have to check the values from SourceSheet2 to see if any were unique to that list.
- When that is done, you should have only added the ones that were missing from your initial search. Then the targetSheet will be in the order of SourceSheet1 All Items, then the extra items from SourceSheet2
- 获取 SourceSheet1 和 SourceSheet2 的 LastRow - 将它们设置为变量 lastRow1 和 lastRow2
- 为每个工作表创建一个行代码。s1Row, s2Row, tRow
- set tRow = 2 对于 TargetSheet 的第一行
- 使用 For 循环循环遍历 SourceSheet1 的每一行。使用这样的东西
- 当代码的第一部分完成循环时，您将完成将 SourceSheet1 中的每个项目添加到 TargetSheet。然后，您必须检查 SourceSheet2 中的值，以查看该列表中是否有唯一值。
- 完成后，您应该只添加初始搜索中缺少的那些。然后 targetSheet 将按照 SourceSheet1 所有项目的顺序，然后是 SourceSheet2 中的额外项目
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
第一阶段：将每个条目从 Sheet1 复制到 Target，同时从 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
阶段二：检查 SourceSheet2 中不在 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
编辑：错字更正
