VBA - 将上一个报告上的列与新报告进行比较以查找新条目

Question

我总共有 4 张纸需要使用。

• 服务器列表1
• 服务器列表2
• 机器列表1
• 机器列表2

旁边带有 (1( 的工作表名称是上周的报告，旁边带有 (2( 的工作表名称是本周的报告。

在每个工作表中，我删除了多个列，因此剩下的只是带有服务器名称或计算机名称的列

从本质上讲，我需要将上周的报告与本周的报告进行比较，并查看添加了哪些新服务器(如果有(以及添加了哪些新机器(如果有(。

相反，我需要做相反的事情，检查哪些服务器已被删除(如果有(以及哪些机器已被移除(如果有(。

使用以下代码，只需切换工作表名称即可轻松完成第二部分。

我在这里找到了以下代码：

https://www.ozgrid.com/forum/forum/help-forums/excel-vba-macros/145223-compare-2-columns-in-different-sheets-and-copy-entire-rows-into-new-sheets

此代码进行比较并复制新外观，但我目前遇到两个问题：

1(代码看起来像卡在无限循环中 - 我需要手动退出代码

2( 在"新建服务器-计算机">工作表上，结果从 A2 行而不是 A1 粘贴

Sub compareSheets()
ThisWorkbook.RefreshAll
Dim rng As Range, c As Range, cfind As Range
Dim ws1 As Worksheet
Set ws1 = Worksheets("New Servers-Machines")
On Error Resume Next
With Worksheets("Last Week Servers")
Set rng = .Range(.Range("A1"), .Range("c1").End(xlDown))
For Each c In rng
c = Replace(c, " ", "")
With Worksheets("This Week Servers")
Set cfind = .Columns("A:A").Cells.Find(what:=c.Value, lookat:=xlWhole)
If cfind Is Nothing Then
c.Resize(1, 1).EntireRow.Copy
ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End With
Next c
Application.CutCopyMode = False
End With
With Worksheets("This Week Servers")
Set rng = .Range(.Range("A1"), .Range("c1").End(xlDown))
For Each c In rng
c = Replace(c, " ", "")
With Worksheets("Last Week Servers")
Set cfind = .Columns("A:A").Cells.Find(what:=c.Value, lookat:=xlWhole)
If cfind Is Nothing Then
c.Resize(1, 1).EntireRow.Copy
ws1.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End With
Next c
Application.CutCopyMode = False
End With
End Sub

更新：

Public Sub FindDifferences1()
Dim firstRange As Range
Dim secondRange As Range
Dim myCell As Range
Dim wks1 As Worksheet, wks2 As Worksheet, wks3 As Worksheet
'Find Removed Wintel Servers
Set wks1 = ActiveWorkbook.Sheets("Last Week Servers List")
Set wks2 = ActiveWorkbook.Sheets("This Week Servers List")
Set wks3 = ActiveWorkbook.Sheets("New Servers")
Set firstRange = wks1.Range("A:A")
Set secondRange = wks2.Range("A:A")
For Each myCell In firstRange
If myCell <> secondRange.Range(myCell.Address) Then
myCell.Copy
wks3.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
wks3.Cells(Rows.Count, 2).End(xlUp).PasteSpecial xlPasteFormats
End If
Next myCell
End Sub

工作表的格式只有一列带有行标题的服务器名称

Answer 1

假设您有 3 个工作表：

• worksheet1- 与worksheet2进行比较
• worksheet2- 与worksheet1进行比较
• worksheet3- 写入值，这些值在worksheet1中是不同的

然后一些简单的代码，因为这个工作得很好：

Public Sub FindDifferences()
Dim firstRange As Range
Dim secondRange As Range
Dim wks1 As Worksheet: Set wks1 = Worksheets(1)
Dim wks2 As Worksheet: Set wks2 = Worksheets(2)
Dim wks3 As Worksheet: Set wks3 = Worksheets(3)
Set firstRange = wks1.UsedRange
Set secondRange = wks2.UsedRange
Dim myCell  As Range
For Each myCell In firstRange
If myCell <> secondRange.Range(myCell.Address) Then
wks3.Range(myCell.Address) = myCell
End If
Next myCell
End Sub

它有什么作用？

• if 循环遍历Worksheets(1)中UsedRange的每个单元格，并将其与Worksheets(2)中的同一单元格进行比较;
• 如果比较不同，则它将Worksheets(1)中的单元格写入Worksheets(3);
• 您可以考虑在Worksheets(1)中为单元格着色，如果也不同;

---

如果您的列位于不同位置，因此您想将列B与列D进行比较，则需要对范围进行一些处理：

Set firstRange = wks1.UsedRange.Columns(2).Cells
Set secondRange = wks1.UsedRange.Columns(4).Cells
For Each myCell In firstRange
If myCell.Value2 <> secondRange.Cells(myCell.Row, secondRange.Column).Value2 Then
wks3.Range(myCell.Address) = myCell.Value2
End If
Next myCell