Question

您好我正在尝试复制差异，同时比较两个工作簿和过去第三个工作簿中的差异。以下代码正在复制第一个差异（行）。代码不能复制两个工作簿的所有差异（行）。请建议如何复制所有差异

Sub findingdiff()
Dim FileSys, objFile, myFolder, c As Object
Dim wb1, wb2 As Workbook
Dim wb3 As ThisWorkbook
Set wb3 = ThisWorkbook
FolderName = ("C:\Users\ashokkumar.d\Desktop\Test\do\")
                Set FileSys = CreateObject("Scripting.FileSystemObject")
                Set myFolder = FileSys.GetFolder(FolderName)
'loop through each file and get date last modified. If largest date then store Filename
        dteFile = DateSerial(1900, 1, 1)
        For Each objFile In myFolder.Files
            If InStr(1, objFile.Name, ".xls") > 0 Then
                If objFile.DateLastModified > dteFile Then
                    dteFile = objFile.DateLastModified
                    strFilename = objFile.Name
                End If
            End If
        Next objFile
'opening of latest file in the folder

                Set wb2 = Workbooks.Open(FolderName & Application.PathSeparator & strFilename)
                Set FileSys = Nothing
                Set myFolder = Nothing
With wb2.Sheets("Sheet1")
Sh1LastRow = .Cells(Rows.Count, "C").End(xlUp).Row
Set Sh1Range = .Range("C1:C" & Sh1LastRow)
End With
 Set wb1 = Workbooks.Open("C:\Users\ashokkumar.d\Desktop\Test\do\AR_Report_Excel_Version_06042017.xls")
With wb1.Sheets("Sheet1")
Sh2LastRow = .Cells(Rows.Count, "C").End(xlUp).Row
Set Sh2Range = .Range("C2:C" & Sh2LastRow)
End With

'compare latest workbook with old workbook
For Each cell In Sh1Range
Set c = Sh2Range.Find( _
what:=cell, LookIn:=xlValues)
If c Is Nothing Then
cell.Interior.ColorIndex = 5
cell.Offset(0, 1).Interior.ColorIndex = 5
cell.EntireRow.Copy wb3.Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)

End If
Next cell
'compare  with sheet 1

For Each cell In Sh2Range
Set c = Sh1Range.Find( _
what:=cell, LookIn:=xlValues)
If c Is Nothing Then
cell.Interior.ColorIndex = 4
cell.Offset(0, 1).Interior.ColorIndex = 4
cell.EntireRow.Copy wb3.Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)

End If
Next cell


End Sub

Answer 1

看起来你每次都将差异粘贴到wb3中的同一行，所以它们只是相互覆盖（假设你在wb1和wb2的列A中没有数据）

如果您将lastrow更改为从C列进行查找然后偏移1，那么每次都应粘贴到新行

With wb2.Sheets("Sheet1")
Sh1LastRow = .Cells(Rows.Count, "C").End(xlUp).Row
Set Sh1Range = .Range("C1:C" & Sh1LastRow)
End With

Set wb1 = Workbooks.Open "C:\Users\ashokkumar.d\Desktop\Test\do\AR_Report_Excel_Version_06042017.xls")
With wb1.Sheets("Sheet1")
Sh2LastRow = .Cells(Rows.Count, "C").End(xlUp).Row
Set Sh2Range = .Range("C1:C" & Sh2LastRow)
End With

'compare latest workbook with old workbook
For Each cell In Sh1Range
Set c = Sh2Range.Find( _
what:=cell, LookIn:=xlValues)
If c Is Nothing Then
cell.Interior.ColorIndex = 5
cell.Offset(0, 1).Interior.ColorIndex = 5
Sh3LastRow = wb3.Sheets("Sheet3").Range("C" & Rows.Count).End(xlUp).Row
cell.EntireRow.Copy wb3.Sheets("Sheet3").Range("A" & Sh3LastRow).Offset(1, 0)
End If

Next cell
'compare  with sheet 1

For Each cell In Sh2Range
Set c = Sh1Range.Find( _
what:=cell, LookIn:=xlValues)
If c Is Nothing Then
cell.Interior.ColorIndex = 4
cell.Offset(0, 1).Interior.ColorIndex = 4
Sh3LastRow = wb3.Sheets("Sheet3").Range("C" & Rows.Count).End(xlUp).Row
cell.EntireRow.Copy wb3.Sheets("Sheet3").Range("A" & Sh3LastRow).Offset(1, 0)
End If

*你还设置了sh1Range从第1行开始，但是sh2Range从第2行开始。我不确定这是否是故意但是已经修改了从第1行开始

Answer 2

这应该是一个评论，但我没有足够的声誉来创建一个，所以这必须这样做。

当你宣布

时

Dim wb1, wb2 As Workbook

仅wb2被声明为Workbook，wb1被声明为Variant。要将wb1和wb2声明为Workbook，请写：

Dim wb1 As Workbook, wb2 As Workbook

与

相同

Dim FileSys, objFile, myFolder, c As Object

哪个应该是

Dim FileSys As Object, objFile As Object, myFolder As Object, c As Object

VBA：如何在与工作簿进行比较时获取行数据并在第三个工作簿中复制数据

2 个答案: