试图识别随机分配在两张独立的Excel表格中的匹配单元格，并将匹配的数据复制并粘贴到第三个表格中

所以我有几个工作表在同一个Excel工作簿，我需要比较。 工作表1是主表，我需要比较工作表1-2,1-3,1-4。 然后，我需要在工作表5的A列中粘贴任何类似的1-2个数据单元格，在工作表5的B列中粘贴类似的1-3个数据单元格，在工作表5的C列中粘贴1-4个类似的数据单元格。让1-2比较工作。 到目前为止，我已经能够将我的testing编号粘贴到表格5的单元格A1中。我遇到了麻烦，因为它只适用于1单元格，并且我不能让程序在A1中粘贴相似度，然后A2 …等，当我有多个类似的项目。 它们只是在单元格A1或整个A列中相互覆盖。 我也遇到了麻烦，因为程序在写入空格时会停止，但是我需要它跳过空格并在遇到它时读取下一个单元格。 这是因为我的数据表非常混乱，数据分散在几个不同列中的数千行上，随机插入空格。 下面是我刚刚读取相似性，并将其粘贴到A1的工作代码。 我应该注意到，我已经考虑添加一个特定的单元格范围，这取决于我在哪个表单上，以便在程序中设置一个终点，但我还没有弄清楚如何使用它。

Sub findDuplicates() ' code to find duplicates in 2 different worksheets Dim rng1, rng2, rngA, cell1, cell2 As Range ' 4 ranges have been defined Set rng1 = Sheets("Sheet1").Range("C:C") 'rng1 defines the existing data in column C and worksheet1 Set rng2 = Sheets("Sheet2").Range("C:C") 'rng2 defines the data in column C and worksheet2 Set rngA = Sheets("Sheet5").Range("A1") For Each cell1 In rng1 If IsEmpty(cell1.Value) Then Exit For 'check for empty rows. If true then exit the program For Each cell2 In rng2 If IsEmpty(cell2.Value) Then Exit For If cell1.Value = cell2.Value Then 'compare data in cell1 and cell2 and then copy/paste if they have equal values cell1.Copy Sheets("Sheet5").Select rngA.Select ActiveSheet.Paste End If 'run the looping process Next cell2 Next cell1 End Sub 

我想象的程序的一般想法是什么样的

 Define ranges Block of code that runs through each cell in sheet 1 comparing it to all cells in sheet 2. Block of code that, when similarities are found, copy/paste that cell on sheet 1 to sheet 5 column A *Program resumes scan from the next cell on sheet 1* Block of code that breaks the program when it hits the end of the specified cell range 

任何帮助，将不胜感激！ 你至less要节省一个星期的工作。

Answer 1

关于你的代码的一些评论：

• Dim rng1, rng2, rngA, cell1, cell2 As Range意味着只有cell2被定义As Range ，而rng1, rng2, rngA, cell1定义As Variant
• 您不需要有2个For循环进行比较，您可以用Matchfunctionreplace第二个For循环，这将为您节省宝贵的运行时间。
• 您需要通过使用NextRow = Sheets("Sheet5").Cells(Sheets("Sheet5").Rows.Count, "A").End(xlUp).Row + 1来查找“Sheet5”中的下一个空行， NextRow = Sheets("Sheet5").Cells(Sheets("Sheet5").Rows.Count, "A").End(xlUp).Row + 1
• 最后，你不需要Select表，以便复制>>粘贴，你可以在1行（见我的代码见下文）。

码

 Sub findDuplicates() ' code to find duplicates in 2 different worksheets ' 4 ranges have been defined Dim rng1 As Range, rng2 As Range, rngA As Range, cell1 As Range, cell2 As Range Dim NextRow As Long 'rng1 defines the existing data in column C and "Sheet1" Set rng1 = Sheets("Sheet1").Range("C:C") 'rng2 defines the data in column C and "Sheet2" Set rng2 = Sheets("Sheet2").Range("C:C") Set rngA = Sheets("Sheet5").Range("A1") For Each cell1 In rng1 If Not IsEmpty(cell1.Value) Then ' only check non-empty cells If Not IsError(Application.Match(cell1.Value, rng2 , 0)) Then ' <-- confirm match was asuccessful ' find next empty row in column "A" in "Sheet5" NextRow = Sheets("Sheet5").Cells(Sheets("Sheet5").Rows.Count, "A").End(xlUp).Row + 1 ' Copy >> Paste in 1 line (without need to Select the Sheets) cell1.Copy Destination:=Sheets("Sheet5").Range("A" & NextRow) End If 'run the looping process End If Next cell1 End Sub 

Answer 2

你的问题是，rngA指向A1，没有任何改变。 在粘贴命令后添加一行：

 ActiveSheet.Paste Set rngA = rngA.Offset(1,0) ' This will move the pasting location one step down