比较列数据后VBA复制行 [英] VBA copy rows after comparing column data
问题描述
我决定尝试改变@Vasily代码，因为他提供了最接近的结果。请点击第二个链接查看他的原始代码，如果需要的话。
所以我原来的问题是比较2个工作表的数据，包括一个eRequest ID列在一个。我需要将文件中的只有1个eRequest ID的数据行复制到新的工作表中。这意味着在两个文件上现有eRequest ID的数据可以被忽略。
所以这里是基于Vasily编辑的代码，它运行正常，没有错误。不过，现在做的是从两个工作表复制所有数据，而不是根据eRequest ID进行过滤，这是我需要的。
Sub test（）
Dim lastRowE& lastRowF& lastRowM& Key As Variant
Dim Cle As Range，Clf As范围'Cle为主库存，Clf为发行版本状态
Dim DicInv作为对象'DicInv为主目录，DicDev发布版本状态
设置DicInv = CreateObject（Scripting.Dictionary）
Dim DicDev As Object
Set DicDev = CreateObject（Scripting.Dictionary）
Application.ScreenUpdating = False
lastRowE = Sheets（JULY15Release_Master Inventory）。单元格（Rows.Count，A）。End（xlUp）.Row
lastRowF = Sheets（JULY15Release_Dev status）。单元格（Rows.Count， A）。End（xlUp）.Row
lastRowM = Sheets（Mismatch）。Cells（Rows.Count，A）。End（xlUp）.Row
'add成dict从单元格匹配的库存中的离子行数
每个Cle In Sheets（JULY15Release_Master Inventory）。范围（A1：A& lastRowE）
如果Cle.Value<> 然后
对于每个Clf In Sheets（JULY15Release_Dev status）。Range（A1：A& lastRowF）
如果Cle.Value = Clf.Value然后DicInv.Add Cle.Row，
Next Clf
End If
下一个Cle
'从Dev中添加字典行号，其中单元格匹配
对于每个Clf In Sheets（JULY15Release_Dev status ）.Range（A1：A& lastRowF）
如果Clf.Value<> 然后
每个Cle In Sheets（JULY15Release_Master Inventory）。范围（A1：A& lastRowE）
如果Clf.Value = Cle.Value然后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
End If
Next Cle
结束
'从Dev
获取不匹配带表格（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
End If
Next Clf
结束
Application.ScreenUpdating = True
End Sub
在我之前的问题中，我被要求分享我的文件，以便这里的大师可以帮助。不幸的是，我不能这样做，因为我只是一个为我现在的公司工作的实习生。他们对他们的文件非常严格，加密了从办公室取出的任何文件。我们也被阻止的网站，如Google Drive和DropBox ..除非你们有另一种方法来共享这些文件（我很乐意遵守!!!!!）我只设法拍摄这两张照片并发布在imgur 。
此图片显示了我的第一个工作表中的数据，主库存和此图像显示了我的第二个工作表中的数据，即发布开发状态。
希望这有帮助，我很抱歉，我无法提供更多的信息。感谢你的帮助，到目前为止，欢呼堆栈溢出！
仍然不知道你想对不同的工作表做什么。但是以下宏会将两张表中不存在的行复制到MisMatch工作表。库存行首先被复制，然后是空行，然后是Dev行。可能需要一些格式化的漂亮的东西，其他的东西可以添加。
我同时使用一个类模块和一个常规模块。
插入课程模块后，您必须重命名课程模块：cMismatch
可能需要一些修改。我很高兴在早上回答问题。
课程模块
< hr>
Option Explicit
私人pID As String
私人pWS As String
私人pRW作为范围
公共属性获取ID（）As String
ID = pID
结束属性
公共属性让ID（值作为字符串）
pID =值
End Property
公共属性获取WS（）As String
WS = pWS
结束属性
公共属性让WS（Value As String）
pWS = Value
结束属性
公共属性获取RW（）作为范围
设置RW = pRW
结束属性
公共属性设置RW（值为范围）
设置pRW =值
结束属性
常规模块
显式
Sub MisMatches（）
Dim cMM As cMisMatch，colMM As Collection
Dim vInv As Variant，vDev As V ariant
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范围，rMM作为范围
Dim I As Long
设置wsINV =工作表（JULY15Release_Master Inventory）
设置wsDEV = Worksheets（JULY15Release_Dev Status）
设置wsMM =工作表（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
结束
下一个我
在错误简历Next
对于I = 1到UBound（vDev）
设置cMM =新建cMisMatch
带cMM
.ID = CStr（vDev（I）.Cells（1，1））
.WS = 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）
结束选择
下一个我
与wsMM.UsedRange
.ClearFormats
.EntireColumn.AutoFit
结束
Application.ScreenUpdating = True
End Sub
函数VisibleDataTable_To_Array（rng As Range）As Variant
'假定所有区域都有相同的列
Dim rwCNT As Long
Dim我长，J长，K长，L长
Dim V（）As Variant
rwCNT = 0
对于I = 1 To rng.Areas.Count
rwCNT = rwCNT + rng.Areas（I）.Rows.Count
下一个我
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
下一个我
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屋！
