比较列数据后VBA复制行

本文介绍了比较列数据后VBA复制行的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！ 问题描述 好，大家好，再来一次所以我已经发布了几个类似的问题，但没有效果..我决定发布另一个，因为我认为这将是相当凌乱的下面评论。我以前的问题的链接是这里和此处 我决定尝试改变@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 可能需要一些修改。我很高兴在早上回答问题。 课程模块 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 hereI 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 VariantDim Cle As Range, Clf As Range 'Cle for Master Inventory, Clf for Release Dev StatusDim DicInv As Object 'DicInv for Master inventory, DicDev for Release Dev StatusSet DicInv = CreateObject("Scripting.Dictionary")Dim DicDev As ObjectSet DicDev = CreateObject("Scripting.Dictionary")Application.ScreenUpdating = FalselastRowE = Sheets("JULY15Release_Master Inventory").Cells(Rows.Count, "A").End(xlUp).RowlastRowF = Sheets("JULY15Release_Dev status").Cells(Rows.Count, "A").End(xlUp).RowlastRowM = Sheets("Mismatch").Cells(Rows.Count, "A").End(xlUp).Row'add into dictionary row number from Inventory where cell is matchedFor 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 IfNext Cle'add into dictionary row number from Dev where cell is matchedFor 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 IfNext Clf'Get mismatch from InventoryWith 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 CleEnd With'Get mismatch from DevWith 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 ClfEnd WithApplication.ScreenUpdating = TrueEnd SubIn 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: cMismatchIt'll probably need some modifications. And I'll be happy to answer questions in the morning.Class ModuleOption ExplicitPrivate pID As StringPrivate pWS As StringPrivate pRW As RangePublic Property Get ID() As String ID = pIDEnd PropertyPublic Property Let ID(Value As String) pID = ValueEnd PropertyPublic Property Get WS() As String WS = pWSEnd PropertyPublic Property Let WS(Value As String) pWS = ValueEnd PropertyPublic Property Get RW() As Range Set RW = pRWEnd PropertyPublic Property Set RW(Value As Range) Set pRW = ValueEnd PropertyRegular ModuleOption ExplicitSub 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 LongSet 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 IDSet loINV = wsINV.ListObjects(1)Set loDEV = wsDEV.ListObjects(1)'get the data ranges, visible (unfiltered rows) onlySet rINV = loINV.DataBodyRange.SpecialCells(xlCellTypeVisible)Set rDEV = loDEV.DataBodyRange.SpecialCells(xlCellTypeVisible)'place the filtered rows into arraysvInv = 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 secondSet colMM = New CollectionFor 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 WithNext IOn Error Resume NextFor 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 WithNext IOn Error GoTo 0'write the resultsApplication.ScreenUpdating = FalsewsMM.Cells.ClearSet 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 SelectNext IWith wsMM.UsedRange .ClearFormats .EntireColumn.AutoFitEnd WithApplication.ScreenUpdating = TrueEnd SubFunction 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 = VEnd Function 这篇关于比较列数据后VBA复制行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！