VBA 比较列数据后复制行
VBA copy rows after comparing column data
好的，大家好，又来了。所以我已经 post 编辑了几个类似的问题，但无济于事。我决定 post 另一个问题，因为我认为继续在下面发表评论会很混乱。我之前问题的 link 是 here and here
我决定尝试更改@Vasily 代码，因为他提供的结果最接近。需要的话请点击第二个link查看他的原代码
所以我最初的问题是比较来自 2 个工作表的数据，这两个工作表都在 "A" 中包含一个 "eRequest ID" 列。我需要将 EITHER FILES 上只有 1 "eRequest ID" 的数据行复制到新工作表 这意味着 上现有 "eRequest ID" 的数据BOTH FILES 可以忽略。
所以这是基于 Vasily 编辑的代码，它运行良好，没有错误。但是，它现在所做的是从两个工作表中复制 ALL ROWS OF DATA，而不是根据 "eRequest ID" 进行过滤，这正是我需要的。
Sub test()
Dim lastRowE&, lastRowF&, lastRowM&, Key As Variant
Dim Cle As Range, Clf As Range 'Cle for Master Inventory, Clf for Release Dev Status
Dim DicInv As Object 'DicInv for Master inventory, DicDev for Release Dev Status
Set DicInv = CreateObject("Scripting.Dictionary")
Dim DicDev As Object
Set DicDev = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
lastRowE = Sheets("JULY15Release_Master Inventory").Cells(Rows.Count, "A").End(xlUp).Row
lastRowF = Sheets("JULY15Release_Dev status").Cells(Rows.Count, "A").End(xlUp).Row
lastRowM = Sheets("Mismatch").Cells(Rows.Count, "A").End(xlUp).Row
'add into dictionary row number from Inventory where cell is matched
For Each Cle In Sheets("JULY15Release_Master Inventory").Range("A1:A" & lastRowE)
If Cle.Value <> "" Then
For Each Clf In Sheets("JULY15Release_Dev status").Range("A1:A" & lastRowF)
If Cle.Value = Clf.Value Then DicInv.Add Cle.Row, ""
Next Clf
End If
Next Cle
'add into dictionary row number from Dev where cell is matched
For Each Clf In Sheets("JULY15Release_Dev status").Range("A1:A" & lastRowF)
If Clf.Value <> "" Then
For Each Cle In Sheets("JULY15Release_Master Inventory").Range("A1:A" & lastRowE)
If Clf.Value = Cle.Value Then DicDev.Add Clf.Row, ""
Next Cle
End If
Next Clf
'Get mismatch from Inventory
With Sheets("JULY15Release_Master Inventory")
For Each Cle In .Range("A1:A" & lastRowE)
If DicInv.exists(Cle.Row) Then 'And Cle.Value <> ""
.Rows(Cle.Row).Copy Sheets("Mismatch").Rows(lastRowM)
lastRowM = lastRowM + 1
End If
Next Cle
End With
'Get mismatch from Dev
With Sheets("JULY15Release_Dev status")
For Each Clf In .Range("A1:A" & lastRowF)
If DicDev.exists(Clf.Row) Then 'And Clf.Value <> ""
.Rows(Clf.Row).Copy Sheets("Mismatch").Rows(lastRowM)
lastRowM = lastRowM + 1
End If
Next Clf
End With
Application.ScreenUpdating = True
End Sub
在我之前的两个问题中，我都被要求共享我的文件，以便这里的专家可以提供帮助。不幸的是，我无法这样做，因为我只是在我现在的公司工作的实习生。他们对自己的文件非常严格，对带出办公室的任何文件进行加密。我们还屏蔽了 Google Drive 和 DropBox 等网站。除非你们有其他方法来共享这些文件，（我很乐意遵守！！！！）我只拍了这两张照片和post 它在 imgur 上。
此 image shows the data in my first worksheet, Master Inventory and this image 显示我的第二个工作表“发布开发状态”中的数据。
希望这对您有所帮助，很抱歉我无法提供更多信息。感谢您到目前为止的帮助，为 Stack Overflow 干杯！
仍然不确定你想用不同的工作表做什么。但是下面的宏会将两个工作表中都不存在的行复制到 MisMatch 工作表中。首先复制 Inventory 行，然后是空行，然后是 Dev 行。可能需要一些格式来美化，还可以添加其他内容。
我同时使用 Class 模块和常规模块。
插入 Class 模块后，必须 重命名 class 模块：cMismatch
它可能需要一些修改。我很乐意在早上回答问题。
Class 模块
Option Explicit
Private pID As String
Private pWS As String
Private pRW As Range
Public Property Get ID() As String
ID = pID
End Property
Public Property Let ID(Value As String)
pID = Value
End Property
Public Property Get WS() As String
WS = pWS
End Property
Public Property Let WS(Value As String)
pWS = Value
End Property
Public Property Get RW() As Range
Set RW = pRW
End Property
Public Property Set RW(Value As Range)
Set pRW = Value
End Property
常规模块
Option Explicit
Sub MisMatches()
Dim cMM As cMisMatch, colMM As Collection
Dim vInv As Variant, vDev As Variant
Dim vMM() As Variant
Dim wsINV As Worksheet, wsDEV As Worksheet, wsMM As Worksheet
Dim loINV As ListObject, loDEV As ListObject
Dim rINV As Range, rDEV As Range, rMM As Range
Dim I As Long
Set wsINV = Worksheets("JULY15Release_Master Inventory")
Set wsDEV = Worksheets("JULY15Release_Dev Status")
Set wsMM = Worksheets("MisMatch")
'If there is more than one table on the worksheet, will need to
' use a better ID
Set loINV = wsINV.ListObjects(1)
Set loDEV = wsDEV.ListObjects(1)
'get the data ranges, visible (unfiltered rows) only
Set rINV = loINV.DataBodyRange.SpecialCells(xlCellTypeVisible)
Set rDEV = loDEV.DataBodyRange.SpecialCells(xlCellTypeVisible)
'place the filtered rows into arrays
vInv = VisibleDataTable_To_Array(rINV)
vDev = VisibleDataTable_To_Array(rDEV)
'collect the mismatches, using the Collection object
'collect all the items from first WS, then remove them if they are also on second
Set colMM = New Collection
For I = 1 To UBound(vInv)
Set cMM = New cMisMatch
With cMM
.ID = CStr(vInv(I).Cells(1, 1))
.WS = wsINV.Name
Set .RW = vInv(I)
colMM.Add cMM, .ID
End With
Next I
On Error Resume Next
For I = 1 To UBound(vDev)
Set cMM = New cMisMatch
With cMM
.ID = CStr(vDev(I).Cells(1, 1))
.WS = wsDEV.Name
Set .RW = vDev(I)
colMM.Add cMM, .ID
If Err.Number = 457 Then
colMM.Remove (.ID)
Err.Clear
End If
End With
Next I
On Error GoTo 0
'write the results
Application.ScreenUpdating = False
wsMM.Cells.Clear
Set rMM = wsMM.Cells(2, 1)
For I = 1 To colMM.Count
Select Case colMM(I).WS
Case wsINV.Name
colMM(I).RW.Copy rMM(I)
Case wsDEV.Name
colMM(I).RW.Copy rMM(I + 1)
End Select
Next I
With wsMM.UsedRange
.ClearFormats
.EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
End Sub
Function VisibleDataTable_To_Array(rng As Range) As Variant
'assumes all areas have same columns
Dim rwCNT As Long
Dim I As Long, J As Long, K As Long, L As Long
Dim V() As Variant
rwCNT = 0
For I = 1 To rng.Areas.Count
rwCNT = rwCNT + rng.Areas(I).Rows.Count
Next I
ReDim V(1 To rwCNT)
K = 0 'array row counter
For I = 1 To rng.Areas.Count
For J = 1 To rng.Areas(I).Rows.Count
K = K + 1
Set V(K) = rng.Areas(I).Rows(J)
Next J
Next I
VisibleDataTable_To_Array = V
End Function
好的，大家好，又来了。所以我已经 post 编辑了几个类似的问题，但无济于事。我决定 post 另一个问题，因为我认为继续在下面发表评论会很混乱。我之前问题的 link 是 here and here
我决定尝试更改@Vasily 代码，因为他提供的结果最接近。需要的话请点击第二个link查看他的原代码
所以我最初的问题是比较来自 2 个工作表的数据，这两个工作表都在 "A" 中包含一个 "eRequest ID" 列。我需要将 EITHER FILES 上只有 1 "eRequest ID" 的数据行复制到新工作表 这意味着 上现有 "eRequest ID" 的数据BOTH FILES 可以忽略。
所以这是基于 Vasily 编辑的代码，它运行良好，没有错误。但是，它现在所做的是从两个工作表中复制 ALL ROWS OF DATA，而不是根据 "eRequest ID" 进行过滤，这正是我需要的。
Sub test()
Dim lastRowE&, lastRowF&, lastRowM&, Key As Variant
Dim Cle As Range, Clf As Range 'Cle for Master Inventory, Clf for Release Dev Status
Dim DicInv As Object 'DicInv for Master inventory, DicDev for Release Dev Status
Set DicInv = CreateObject("Scripting.Dictionary")
Dim DicDev As Object
Set DicDev = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
lastRowE = Sheets("JULY15Release_Master Inventory").Cells(Rows.Count, "A").End(xlUp).Row
lastRowF = Sheets("JULY15Release_Dev status").Cells(Rows.Count, "A").End(xlUp).Row
lastRowM = Sheets("Mismatch").Cells(Rows.Count, "A").End(xlUp).Row
'add into dictionary row number from Inventory where cell is matched
For Each Cle In Sheets("JULY15Release_Master Inventory").Range("A1:A" & lastRowE)
If Cle.Value <> "" Then
For Each Clf In Sheets("JULY15Release_Dev status").Range("A1:A" & lastRowF)
If Cle.Value = Clf.Value Then DicInv.Add Cle.Row, ""
Next Clf
End If
Next Cle
'add into dictionary row number from Dev where cell is matched
For Each Clf In Sheets("JULY15Release_Dev status").Range("A1:A" & lastRowF)
If Clf.Value <> "" Then
For Each Cle In Sheets("JULY15Release_Master Inventory").Range("A1:A" & lastRowE)
If Clf.Value = Cle.Value Then DicDev.Add Clf.Row, ""
Next Cle
End If
Next Clf
'Get mismatch from Inventory
With Sheets("JULY15Release_Master Inventory")
For Each Cle In .Range("A1:A" & lastRowE)
If DicInv.exists(Cle.Row) Then 'And Cle.Value <> ""
.Rows(Cle.Row).Copy Sheets("Mismatch").Rows(lastRowM)
lastRowM = lastRowM + 1
End If
Next Cle
End With
'Get mismatch from Dev
With Sheets("JULY15Release_Dev status")
For Each Clf In .Range("A1:A" & lastRowF)
If DicDev.exists(Clf.Row) Then 'And Clf.Value <> ""
.Rows(Clf.Row).Copy Sheets("Mismatch").Rows(lastRowM)
lastRowM = lastRowM + 1
End If
Next Clf
End With
Application.ScreenUpdating = True
End Sub
在我之前的两个问题中，我都被要求共享我的文件，以便这里的专家可以提供帮助。不幸的是，我无法这样做，因为我只是在我现在的公司工作的实习生。他们对自己的文件非常严格，对带出办公室的任何文件进行加密。我们还屏蔽了 Google Drive 和 DropBox 等网站。除非你们有其他方法来共享这些文件，（我很乐意遵守！！！！）我只拍了这两张照片和post 它在 imgur 上。
此 image shows the data in my first worksheet, Master Inventory and this image 显示我的第二个工作表“发布开发状态”中的数据。
希望这对您有所帮助，很抱歉我无法提供更多信息。感谢您到目前为止的帮助，为 Stack Overflow 干杯！
仍然不确定你想用不同的工作表做什么。但是下面的宏会将两个工作表中都不存在的行复制到 MisMatch 工作表中。首先复制 Inventory 行，然后是空行，然后是 Dev 行。可能需要一些格式来美化，还可以添加其他内容。
我同时使用 Class 模块和常规模块。 插入 Class 模块后，必须 重命名 class 模块：cMismatch
它可能需要一些修改。我很乐意在早上回答问题。
Class 模块
Option Explicit
Private pID As String
Private pWS As String
Private pRW As Range
Public Property Get ID() As String
ID = pID
End Property
Public Property Let ID(Value As String)
pID = Value
End Property
Public Property Get WS() As String
WS = pWS
End Property
Public Property Let WS(Value As String)
pWS = Value
End Property
Public Property Get RW() As Range
Set RW = pRW
End Property
Public Property Set RW(Value As Range)
Set pRW = Value
End Property
常规模块
Option Explicit
Sub MisMatches()
Dim cMM As cMisMatch, colMM As Collection
Dim vInv As Variant, vDev As Variant
Dim vMM() As Variant
Dim wsINV As Worksheet, wsDEV As Worksheet, wsMM As Worksheet
Dim loINV As ListObject, loDEV As ListObject
Dim rINV As Range, rDEV As Range, rMM As Range
Dim I As Long
Set wsINV = Worksheets("JULY15Release_Master Inventory")
Set wsDEV = Worksheets("JULY15Release_Dev Status")
Set wsMM = Worksheets("MisMatch")
'If there is more than one table on the worksheet, will need to
' use a better ID
Set loINV = wsINV.ListObjects(1)
Set loDEV = wsDEV.ListObjects(1)
'get the data ranges, visible (unfiltered rows) only
Set rINV = loINV.DataBodyRange.SpecialCells(xlCellTypeVisible)
Set rDEV = loDEV.DataBodyRange.SpecialCells(xlCellTypeVisible)
'place the filtered rows into arrays
vInv = VisibleDataTable_To_Array(rINV)
vDev = VisibleDataTable_To_Array(rDEV)
'collect the mismatches, using the Collection object
'collect all the items from first WS, then remove them if they are also on second
Set colMM = New Collection
For I = 1 To UBound(vInv)
Set cMM = New cMisMatch
With cMM
.ID = CStr(vInv(I).Cells(1, 1))
.WS = wsINV.Name
Set .RW = vInv(I)
colMM.Add cMM, .ID
End With
Next I
On Error Resume Next
For I = 1 To UBound(vDev)
Set cMM = New cMisMatch
With cMM
.ID = CStr(vDev(I).Cells(1, 1))
.WS = wsDEV.Name
Set .RW = vDev(I)
colMM.Add cMM, .ID
If Err.Number = 457 Then
colMM.Remove (.ID)
Err.Clear
End If
End With
Next I
On Error GoTo 0
'write the results
Application.ScreenUpdating = False
wsMM.Cells.Clear
Set rMM = wsMM.Cells(2, 1)
For I = 1 To colMM.Count
Select Case colMM(I).WS
Case wsINV.Name
colMM(I).RW.Copy rMM(I)
Case wsDEV.Name
colMM(I).RW.Copy rMM(I + 1)
End Select
Next I
With wsMM.UsedRange
.ClearFormats
.EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
End Sub
Function VisibleDataTable_To_Array(rng As Range) As Variant
'assumes all areas have same columns
Dim rwCNT As Long
Dim I As Long, J As Long, K As Long, L As Long
Dim V() As Variant
rwCNT = 0
For I = 1 To rng.Areas.Count
rwCNT = rwCNT + rng.Areas(I).Rows.Count
Next I
ReDim V(1 To rwCNT)
K = 0 'array row counter
For I = 1 To rng.Areas.Count
For J = 1 To rng.Areas(I).Rows.Count
K = K + 1
Set V(K) = rng.Areas(I).Rows(J)
Next J
Next I
VisibleDataTable_To_Array = V
End Function