问题
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!
回答1:
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
来源：https://stackoverflow.com/questions/30090517/vba-copy-rows-after-comparing-column-data