基本上我有比较两个工作表的脚本，该脚本将一列中的值与新工作表进行比较，如果找到该值，它将把信息从旧工作表“ B”复制到新工作表“ B”列。
脚本运行正常（感谢作者）
我试图将其配置为不仅搜索和比较1列，而且还比较2，如果新表中的X AND Y列等于X AND Y，它将执行相同的任务。
这样做的原因是，有时我会在几个不同的行中搜索它的值，因此当它进行比较时，它会在几个地方找到它。虽然此脚本仅在具有唯一的“查找”值时才有效。
可以帮我进行编辑，使其适合“查找”并比较“ P”列和“ V”列，如果它们在新表中相同，它将把“ B”列中的值复制到“ B”中“新工作表。
Match value: hw-descriptor:pTEXT1^:mTEXT2^:uTEXT3^
Element value: :pTEXT1^
Element value: :mTEXT2^
Element value: :uTEXT3^
Match value: hw-descriptor:pTEXT8^:mTEXT8^:uTEXT83^
Element value: :pTEXT8^
Element value: :mTEXT8^
Element value: :uTEXT83^
还有一件额外的事情：您能帮我让它在作为评论插入的列表（新表）中显示缺失的标签吗？如果在Msgbox中有数百个缺少的标签全部显示出来，将会很敬畏。
答案 0 :(得分：1)
尝试一下：
Sub movecommentsInternode()
Dim Wb As Workbook
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim wsMissingTags As Worksheet
Dim rSourcePCol As Range
Dim rSourcePCell As Range
Dim rDestPCol As Range
Dim rFound As Range
Dim sFirst As String
Dim sNotFound As String
Dim bFound As Boolean
Dim aHeaders() As Variant
Dim aMissingTags As Variant
Set Wb = ActiveWorkbook
Set wsSource = Wb.Sheets("Internode Buffer")
Set wsDest = Wb.Sheets("DataInternode")
Set rSourcePCol = wsSource.Range("P2", wsSource.Cells(wsSource.Rows.Count, "P").End(xlUp))
Set rDestPCol = wsDest.Range("P2", wsDest.Cells(wsDest.Rows.Count, "P").End(xlUp))
If rSourcePCol.Row < 2 Then
MsgBox "No comment available, therefor no import is needed " ' & wsSource.Name
Exit Sub
ElseIf rDestPCol.Row < 2 Then
MsgBox "Data Sheet is empty, please import the correct IO-List to be able to merge the comments " ' & wsDest.Name
Exit Sub
End If
For Each rSourcePCell In rSourcePCol.Cells
bFound = False
Set rFound = rDestPCol.Find(rSourcePCell.Value, rDestPCol.Cells(rDestPCol.Cells.Count), xlValues, xlWhole)
If Not rFound Is Nothing Then
sFirst = rFound.Address
Do
If rSourcePCell.Offset(, 6).Value = rFound.Offset(, 6).Value Then
rFound.Offset(, -14).Value = rSourcePCell.Offset(, -14).Value
bFound = True
End If
If bFound = True Then Exit Do 'First match for both columns found, exit find loop (this line can be removed if preferred)
Set rFound = rDestPCol.FindNext(rFound)
Loop While rFound.Address <> sFirst
End If
If bFound = False Then sNotFound = sNotFound & "|" & rSourcePCell.Value & vbTab & rSourcePCell.Offset(, 6).Value
Next rSourcePCell
If Len(sNotFound) = 0 Then
MsgBox ("Import completed" & vbCrLf & "All comments have been merged with the new imported IO-List")
Else
On Error Resume Next
Set wsMissingTags = Wb.Worksheets("Missing Tags")
On Error GoTo 0
If wsMissingTags Is Nothing Then
'Missing Tags worksheet doesn't exist, create it and add headers
aHeaders = Array(wsSource.Range("P1").Value, wsSource.Range("V1").Value)
Set wsMissingTags = Wb.Worksheets.Add(After:=Wb.Worksheets(Wb.Worksheets.Count))
wsMissingTags.Name = "Missing Tags"
With wsMissingTags.Range("A1").Resize(, UBound(aHeaders) - LBound(aHeaders) + 1)
.Value = aHeaders
.Font.Bold = True
.Borders(xlEdgeBottom).LineStyle = xlContinuous
End With
Else
'Missing Tags worksheet already exists, clear previous contents (if any)
wsMissingTags.Range("A1").CurrentRegion.Offset(1).ClearContents
End If
aMissingTags = Split(Mid(sNotFound, 2), "|")
With wsMissingTags.Range("A2").Resize(UBound(aMissingTags) - LBound(aMissingTags) + 1)
.Value = Application.Transpose(aMissingTags)
.TextToColumns .Cells, xlDelimited, Tab:=True
End With
MsgBox "Import completed" & vbCrLf & "See the Missing Tags worksheet for a list of tag-comments that have not been merged with new IO-List."
End If
End Sub
答案 1 :(得分：0)
这是一个很好的代码。我对其进行了修改和尝试，并根据我对您要求的理解进行了工作。修改后的完整代码为：
Sub movecommentsInternode()
Dim Wb As Workbook
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rSourceHCol As Range
Dim rDestHCol As Range
Dim rdestHCell As Range
Dim rSourceHCell As Range
Dim rSourceHCol2 As Range 'added
Dim rDestHCol2 As Range 'added
Dim rSourceHCell2 As Range 'added
Dim rdestHCell2 As Range 'added
Dim rFound As Range
Dim sFirst As String
Dim sNotFound As String
Set Wb = ActiveWorkbook
Set wsSource = Wb.Sheets("Internode Buffer")
Set wsDest = Wb.Sheets("DataInternode")
Set rSourceHCol = wsSource.Range("H2", wsSource.Cells(wsSource.Rows.Count, "H").End(xlUp))
Set rDestHCol = wsDest.Range("H2", wsDest.Cells(wsDest.Rows.Count, "H").End(xlUp))
'Next two lines added
Set rSourceHCol2 = wsSource.Range("V2", wsSource.Cells(wsSource.Rows.Count, "V").End(xlUp))
Set rDestHCol2 = wsDest.Range("V2", wsDest.Cells(wsDest.Rows.Count, "V").End(xlUp))
If rSourceHCol.Row < 2 Or rSourceHCol2.Row < 2 Then ' condition modified
MsgBox "No comment available, therefor no import is needed " ' & wsSource.Name
Exit Sub
ElseIf rDestHCol.Row < 2 Or rDestHCol2.Row < 2 Then ' condition modified
MsgBox "Data Sheet is empty, please import the correct IO-List to be able to merge the comments " ' & wsDest.Name
Exit Sub
End If
For Each rSourceHCell In rSourceHCol.Cells
Set rSourceHCell2 = rSourceHCell.Offset(0, 14) 'corresponding value in V Col Source Sheet
Set rFound = rDestHCol.Find(rSourceHCell.Value, rDestHCol.Cells(rDestHCol.Cells.Count), xlValues, xlWhole)
If rFound Is Nothing Then
sNotFound = sNotFound & Chr(10) & rSourceHCell.Value
Else
sFirst = rFound.Address
Do
'Next two lines and if clause added
Set rdestHCell2 = rFound.Offset(0, 14) 'corresponding value in V Col Destination Sheet
If rSourceHCell2.Value = rdestHCell2.Value Then ' added
rFound.Offset(0, -6).Value = rSourceHCell.Offset(0, -6).Value 'offset from H to B
End If
Set rFound = rDestHCol.FindNext(rFound)
Loop While rFound.Address <> sFirst
End If
Next rSourceHCell
If Len(sNotFound) = 0 Then
MsgBox ("Import completed" & vbCrLf & "All comments have been merged with the new imported IO-List")
Else
MsgBox ("Import completed" & vbCrLf & "The following tag-comments have not been merged with new IO-List:" & sNotFound)
End If
End Sub
编辑：第Set rSourceHCell2 = rSourceHCell.Offset(0, 14)行移到了For Each rSourceHCell In rSourceHCol.Cells行之后。如果不起作用，请尝试使用If StrComp(rSourceHCell2.Value, rDestHCell2.Value) = 0 Then代替If rSourceHCell2.Value = rdestHCell2.Value Then