VBA在比较列数据后复制行 [英] VBA copy rows after comparing column data
问题描述
好的，大家，再次。所以我已经发布了几个类似的问题，但没有用。我决定发布另一个，因为我认为这将是相当混乱，以保持评论以下。我之前问题的链接是此处 a>和此处
我决定尝试改变@Vasily代码，因为他提供最接近的结果。如果需要，请点击第二个链接查看他的原始代码。
所以我原来的问题是比较2个工作表的数据，包括一个eRequest ID列在一个。我需要将 EFS文件中只有1个eRequest ID的数据行复制到新工作表中这意味着两个文件上现有的eRequest ID数据可以被忽略。
这里是基于Vasily编辑的代码，它运行正常，没有错误。但是，它现在是从两个工作表复制所有数据，它不根据eRequest ID过滤，这是我需要的。
子测试（）
Dim lastRowE& amp; lastRowF& lastRowM&范围'Cle的主库存，Clf为发布Dev状态
Dim DicInv As Object'DicInv为主库存，DicDev为发布Dev状态
设置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从单元格匹配的库存到字典行号
对于每个表格（JULY15Release_Master Inventory）。范围（A1：A& lastRowE）
如果Cle.Value<> 然后
对于表中的每个Clf（JULY15Release_Dev status）。范围（A1：A& lastRowF）
如果Cle.Value = Clf.Value then DicInv.Add Cle.Row，
下一个Clf
结束如果
下一个Cle
'从单元格匹配的Dev添加到字典行号
对于表格中的每个Clf（JULY15Release_Dev status ）.Range（A1：A& lastRowF）
如果Clf.Value<> 然后
对于每个表格（JULY15Release_Master Inventory）。范围（A1：A& lastRowE）
如果Clf.Value = Cle.Value then DicDev.Add Clf.Row，
下一个Cle
结束如果
下一个Clf
'从库存获取不匹配
使用表格（JULY15Release_Master Inventory）
对于每个Cle In。范围（A1：A& lastRowE）
如果DicInv.exists（Cle.Row）Then'And Cle.Value<
.Rows（Cle.Row）.Copy Sheets（Mismatch）。rows（lastRowM）
lastRowM = lastRowM + 1
如果
结束下一个Cle
End With
'从Dev
获取不匹配with Sheets（JULY15Release_Dev status）
对于每个Clf In .Range（A1：A& lastRowF）
如果DicDev .exists（Clf.Row）Then'And Clf.Value<>
.Rows（Clf.Row）.Copy Sheets（Mismatch）。rows（lastRowM）
lastRowM = lastRowM + 1
如果
结束下一页Clf
End With
Application.ScreenUpdating = True
End Sub
在我以前的问题中，我被要求共享我的文件，以便这里的大师可以帮助。不幸的是，我不能这样做，因为我只是一个实习生为我现有的公司工作。他们对他们的文件非常严格，加密任何从办公室取出的文件。我们也被封锁的网站，如谷歌驱动器和DropBox ..除非你们有另一种方法来共享这些文件，（我会很高兴遵守!!!!!）我只是设法拿这两个图片，并张贴在imgur 。
此图片显示了我第一个工作表中的数据，主库存，此图片显示了我的第二个工作表（发布版本状态）中的数据。
希望这有帮助，我很抱歉，我无法提供更多信息。感谢您迄今为止的帮助，欢呼Stack Overflow！
仍然不确定你想要做的不同的工作表。但是下面的宏会将两个工作表中不存在的行复制到MisMatch工作表。首先复制库存行，然后是空行，然后是Dev行。可能需要一些格式化的漂亮的东西，可以添加其他东西。
我使用类模块和常规模块。
插入类模块后，您必须重命名类模块：cMismatch
这可能需要一些修改。
$ b hr>
选项显式
私有pID作为字符串
私有pWS作为字符串
私有pRW作为范围
公共属性Get ID（）As String
ID = pID
结束属性
公共属性让ID（值为字符串）
pID =值
结束属性
公共属性Get WS（）As String
WS = pWS
结束属性
公共属性让WS（值为字符串）
pWS =值
结束属性
公共属性Get RW（）As范围
设置RW = pRW
结束属性
公共属性集RW ）
设置pRW =值
结束属性
常规模块
显式
Sub MisMatches（）
Dim cMM As cMisMatch，colMM As Collection
Dim vInv As Variant，vDev As Variant
Dim vMM（）As Variant
Dim wsINV As工作表，wsDEV作为工作表，wsMM作为工作表
Dim loINV as ListObject，loDEV as ListObject
Dim rINV As Range，rDEV As Range，rMM As Range
Dim I As Long
设置wsINV = Worksheets（JULY15Release_Master Inventory）
设置wsDEV = Worksheets（JULY15Release_Dev Status）
设置wsMM = Worksheets（MisMatch）
'如果工作表上有多个表，需要
'使用更好的ID
设置loINV = wsINV.ListObjects（1）
设置loDEV = wsDEV.ListObjects 1）
获取数据范围，仅可见（未过滤的行）
设置rINV = loINV.DataBodyRange.SpecialCells（xlCellTypeVisible）
设置rDEV = loDEV。 DataBodyRange.SpecialCells（xlCellTypeVisible）
'将过滤的行放入数组
vInv = VisibleDataTable_To_Array（rINV）
vDev = VisibleDataTable_To_Array（rDEV）
'收集不匹配，使用Collection对象
'从第一个WS收集所有项目，然后删除它们，如果他们也在第二个
设置colMM =新集合
对于I = 1到UBound vInv）
设置cMM =新的cMisMatch
使用cMM
.ID = CStr（vInv（I）.Cells（1,1））
.WS = wsINV.Name
设置.RW = vInv（I）
colMM.Add cMM，.ID
结束于
下一页I
出错恢复下一页
I = 1到UBound（vDev）
设置cMM =新的cMisMatch
使用cMM
.ID = CStr（vDev（I）.Cells（1,1））
。 = wsDEV.Name
设置.RW = vDev（I）
colMM.Add cMM，.ID
如果Err.Number = 457则
colMM.Remove（.ID）
Err.Clear
结束如果
结束于
下一页I
出错GoTo 0
写结果
Application.ScreenUpdating = False
wsMM.Cells.Clear
设置rMM = wsMM.Cells（2，1）
对于I = 1到colMM.Count
选择大小写colMM （I）.WS
案例wsINV.Name
colMM（I）.RW.Copy rMM（I）
案例wsDEV.Name
colMM（I）.RW.Copy rMM （I + 1）
结束选择
下一页I
使用wsMM.UsedRange
.ClearFormats
.EntireColumn.AutoFit
结束于
Application.ScreenUpdating = True
End Sub
函数VisibleDataTable_To_Array（rng As Range）As Variant
'假设所有区域都有相同的列
Dim rwCNT As Long
Dim I As Long，J As Long，K As Long，L As Long
Dim V（）As Variant
rwCNT = 0
I = 1 To rng.Areas.Count
rwCNT = rwCNT + rng.Areas（I）.Rows.Count
下一页I
ReDim V（1到rwCNT）
K = 0'数组行计数器
对于I = 1到rng.Areas.Count
对于J = 1到rng.Areas（I）.Rows.Count
K = K + 1
设置V（K）= rng.Areas（I）.Rows（J）
下一页J
下一页I
VisibleDataTable_To_Array = V
函数
Okay hi everyone, again. So I have already posted several similar questions but to no avail.. I decided to post another one as I think it would be pretty messy to keep commenting below. The links for my previous questions are here and here
I decided to try and change @Vasily codes as his provides the closest results. Please click the second link to view his original codes if need be.
So my original problem was to compare data from 2 worksheets, both which includes an "eRequest ID" column in "A". I need to copy the rows of data with only 1 "eRequest ID" on EITHER FILES into a new worksheet This means that data with existing "eRequest ID" on BOTH FILES can be ignored.
So here are the edited codes based on Vasily and it runs fine, without errors. However, what it does now is copy ALL ROWS OF DATA from both worksheets, its not filtering according to the "eRequest ID", which is what I need.
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
In both my previous questions, I was asked to share my files so that the gurus here could help out. Unfortunately, I am unable to do so as I am simply an intern working for my current company. They are very strict with their files, encrypting any file that is taken out of the office. We are also blocked sites such as Google Drive and DropBox.. Unless if you guys have another method to share these files, (which I would gladly comply!!!!!) I only managed to take these two pictures and post it on imgur.
This image shows the data in my first worksheet, Master Inventory and this image shows the data in my second worksheet, Release Dev Status.
Hope this helps, and I am very sorry that I'm not able to provide more information. Thankful for your help so far, cheers to Stack Overflow!
Still not sure what you want to do with the different sheets. But the following macro will copy the rows that are not present in both sheets to the MisMatch worksheet. The Inventory rows are copied first, then a blank line, then the Dev rows. Probably need some formatting to pretty things up, and other stuff could be added.
I use both a Class module and a Regular module. After you Insert the Class module, you must rename the class module: cMismatch
It'll probably need some modifications. And I'll be happy to answer questions in the morning.
Class Module
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
Regular Module
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
这篇关于VBA在比较列数据后复制行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
