我有一张excel,有3张。在表1和表2中,我每个大约有10列,但总行数不同。我想检查工作表2中的数据是否在工作表1中。如果它有匹配,则不执行任何操作,但如果没有匹配则将整行复制到工作表3中。
这是我的代码但我认为我弄错了
Sub test()
Dim rng As Range, c As Range, cfind As Range
On Error Resume Next
Worksheets("sheet3").Cells.Clear
With Worksheets("sheet1")
Set rng = Range(.Range("A2"), .Range("a2").End(xlDown))
For Each c In rng
With Worksheets("sheet2")
Set cfind = .Columns("A:A").Cells.Find _
(what:=c.Value, lookat:=xlWhole)
If cfind Is Nothing Then GoTo line1
'c.EntireRow.Copy Worksheets("sheet3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
c.Copy Worksheets("sheet3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
c.Offset(0, 2).Copy Worksheets("sheet3").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
End With 'sheet 2
line1:
Next c
Application.CutCopyMode = False
End With 'sheet 1
如下图所示,请参阅
第1页
第2页
第3页
表3是我的预期输出。我可以获得这样的输出。 请帮忙。
感谢。
答案 0 :(得分:2)
试试这个"
Sub test()
Dim rng As Range, c As Range, cfind As Range
On Error Resume Next
Worksheets(3).Cells.Clear
With Worksheets(1)
Set rng = .Range(.Range("A2"), .Range("a2").End(xlDown)) 'added . (dot) in front of first range
For Each c In rng
With Worksheets(2)
Set cfind = .Columns("A:A").Cells.Find _
(what:=c.Value, lookat:=xlWhole)
If cfind Is Nothing Then
'change the "10" in "Resize(1, 10)" to the number of columns you have
c.Resize(1, 10).Copy Worksheets(3).Cells(Worksheets(3).Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
End With 'sheet 2
Next c
Application.CutCopyMode = False
End With 'sheet 1
End Sub
要检查其他工作表上每一行的每一行,需要采用不同的方法。如:
Sub CopyMissingRecords()
'compare whole record in row on 1st worksheet with all records in rows on 2nd worksheet
'and if there is no such row in the 2nd worksheet, then copy the missing record to 3rd worksheet
'repeat for all records on 1st worksheet
Dim varToCopy() As Variant
Dim varToCompare() As Variant
Dim intCopyRow As Integer
Dim intCopyRowMax As Integer
Dim intToCompareRow As Integer
Dim intToCompareRowMax As Integer
Dim bytColumnsInData As Byte
Dim intMisMatchCounter As Integer
Dim intComparingLoop As Integer
Dim intRowMisMatch As Integer
bytColumnsInData = 10 ' change to your situation
'clear everything in our output columns in Worksheets(3)
With Worksheets(3)
.Range(.Cells(2, 1), .Cells(.Rows.Count, bytColumnsInData)).Clear
End With
With Worksheets(1)
'last row in Worksheets(1)
intCopyRowMax = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
'compare each row in Worksheets(1)
For intCopyRow = 2 To intCopyRowMax
'store the first row record from Worksheets(1) into memory
ReDim varToCopy(0)
varToCopy(0) = .Range(.Cells(intCopyRow, 1), .Cells(intCopyRow, bytColumnsInData))
With Worksheets(2)
'last row in Worksheets(2)
intToCompareRowMax = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
'loop through all rows in Worksheets(2)
For intToCompareRow = 2 To intToCompareRowMax
'store the actual row record from Worksheets(2) into memory
ReDim varToCompare(0)
varToCompare(0) = .Range(.Cells(intToCompareRow, 1), .Cells(intToCompareRow, bytColumnsInData))
'compare each column from the row record in Worksheets(1), with each column from the row record in Worksheets(2)
For intComparingLoop = 1 To bytColumnsInData
'if any of the cells from Worksheets(1) in compared row are different than cells from Worksheets(2) in compared row
'just one difference in row is enough to consider this record as missing
If varToCopy(0)(1, intComparingLoop) <> varToCompare(0)(1, intComparingLoop) Then
'store how many row MisMatches are there in data
intRowMisMatch = intRowMisMatch + 1
Exit For
End If
Next intComparingLoop
Next intToCompareRow 'next row in Worksheets(2)
'if there are as many row mismatches as there are row records in Worksheets(2)
If intRowMisMatch = intToCompareRowMax - 1 Then
With Worksheets(3)
'copy the entire row from Worksheets(1) to the next available row in Worksheets(3)
Worksheets(1).Range(Worksheets(1).Cells(intCopyRow, 1), Worksheets(1).Cells(intCopyRow, bytColumnsInData)).Copy _
Destination:=.Cells(.Cells.Rows.Count, 1).End(xlUp).Offset(1, 0)
End With 'Worksheets(3)
End If
'reset the counter
intRowMisMatch = 0
End With 'Worksheets(2)
Next intCopyRow 'next row in Worksheets(1)
End With 'Worksheets(1)
End Sub