Question

好的，大家好。所以我已经发布了几个类似的问题，但无济于事。我决定发布另一个，因为我认为继续评论下面会非常混乱。我之前提问的链接是here和here

我决定尝试更改@Vasily代码，因为他提供了最接近的结果。如果需要，请点击第二个链接查看原始代码。

所以我最初的问题是比较来自2个工作表的数据，这两个工作表都包含“A”中的“eRequest ID”列。我需要将 EITHER FILES上只有1个“eRequest ID”的数据行复制到新工作表中这意味着 BOTH FILES 上现有“eRequest ID”的数据可以被忽略了。

所以这里是基于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

在我之前的两个问题中，我被要求分享我的文件，以便这里的大师可以提供帮助。不幸的是，我无法这样做，因为我只是一名为我现在的公司工作的实习生。他们对文件非常严格，加密从办公室取出的任何文件。我们也是封锁的网站，如谷歌驱动器和DropBox ..除非你们有另一种方法来共享这些文件，（我很乐意遵守!!!!!）我只是设法拍摄这两张照片并发布在imgur上。

此image显示我的第一个工作表中的数据，主库存，此image显示我的第二个工作表中的数据，即发布开发状态。

希望这会有所帮助，我很抱歉我无法提供更多信息。感谢你的帮助到目前为止，欢呼Stack Overflow！

Answer 1

仍然不确定你想用不同的床单做什么。但是下面的宏会将两个工作表中不存在的行复制到MisMatch工作表。首先复制Inventory行，然后复制一个空行，然后复制Dev行。可能需要一些格式化的东西，可以添加其他东西。

我同时使用Class模块和Regular模块。插入类模块后，您必须重命名类模块：cMismatch

它可能需要一些修改。我很乐意在早上回答问题。

课程模块

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

比较列数据

1 个答案: