将 A 列与 C 列进行比较，将匹配的单元格从位置移动到相应行的 B 列答案

【问题标题】：Compare column A with column C, Move matching Cell from location to column B on corresponding row将 A 列与 C 列进行比较，将匹配的单元格从位置移动到相应行的 B 列
【发布时间】：2014-12-02 13:14:32
【问题描述】：

Sub Match()
Dim var As Variant, iSheet As Integer, iRow As Long, iRowL As Long, bln As Boolean, rng1 As Range, rng2 As Range, i As Long, j As Long

  If Not IsEmpty(rng1) Then
     For i = 1 To Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
     Set rng1 = Sheets("Sheet1").Range("A" & i)
     
     For j = 1 To Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
        Set rng2 = Sheets("Sheet1").Range("C" & j)
        
        bln = False
        var = Application.Match(rng1.Value, rng2, 0)
        

        If Not IsError(var) Then
           bln = True
           Exit For
           Exit For
       End If
        Set rng2 = Nothing
    Next j
    Set rng1 = Nothing
Next i
    
For i = 1 To Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
     Set rng1 = Sheets("Sheet1").Range("A" & i)
     

  If bln = False Then
     Cells(rng1).Font.Bold = False
     Else
     Cells(rng1).Font.Bold = True
  End If
   Next i
   End If
Application.ScreenUpdating = True
End Sub

Sub CompareAndHighlight()

    Dim rng1 As Range, rng2 As Range, i As Long, j As Long
    For i = 1 To Sheets("sheet1").Range("C" & Rows.Count).End(xlUp).Row
        Set rng1 = Sheets("sheet1").Range("C" & i)
        For j = 1 To Sheets("sheet2").Range("C" & Rows.Count).End(xlUp).Row
            Set rng2 = Sheets("sheet2").Range("C" & j)
            If StrComp(Trim(rng1.Text), Trim(rng2.Text), vbTextCompare) = 0 Then
                rng1.Interior.Color = RGB(255, 255, 0)
            End If
            Set rng2 = Nothing
        Next j
        Set rng1 = Nothing
    Next i

End Sub

我正在尝试将数据列 A 与列 C 中的数据进行比较

然而挑战是，如果有匹配，我需要将单元格从 C 列移动到相应行的 B 列。

很遗憾我还不能发布图片，我希望这足够清楚，有人支持我吗？

我即兴使用“代码 sn-p 来显示假设数据排列在 A B 和 C 列中的数据应该是什么样子

Before 

A12334		A12352
A12335		A12353
A12336		A12339
A12337		A12340
A12338		A12341
A12339		A12354
A12340		A12355
A12341		A12356
A12342		A22354
A12343		A22356
A12344		A22358
A12345		A22360
A12346		A22362
A12347		A22364
A12348		A22366
A12349		A22368
A12350		A22370
A12351		A22372
A12352		A12357
A12353		A12358
A12354		A12334
A12355		A12335
A12356		A12336
A12357		A12337
A12358		A12338
A12359		A22370
A12360		A22372
A12361		A12361

After:

A12334	A12334	
A12335	A12335	
A12336	A12336	
A12337	A12337	
A12338	A12338	
A12339	A12339	
A12340	A12340	
A12341	A12341	
A12342		A22354
A12343		A22356
A12344		A22358
A12345		A22360
A12346		A22362
A12347		A22364
A12348		A22366
A12349		A22368
A12350		A22370
A12351		A22372
A12352	A12352	
A12353	A12353	
A12354	A12354	
A12355	A12355	
A12356	A12356	
A12357	A12357	
A12358	A12358	
A12359		A22370
A12360		A22372
A12361		A12361

【问题讨论】：

到目前为止你尝试过什么代码？ SO 不是代码外包平台。您需要分享您尝试过的内容以及遇到的问题。 stackoverflow.com/help/on-topic
嗨，我已经添加了一个我之前做的脚本来完成一个更简单的任务并使用了 StrComp，但是我没有尝试使用 MATCH 函数，因为我需要知道单元格的位置才能移动它（这就是我对如何解决的看法）第二个是我迄今为止的尝试，我已经改变了很多，目前完全没有做任何事情。一个正确方向的观点将非常受欢迎！（很抱歉在我没想到有人编写代码之前没有添加代码，而是让我走上正轨！）

标签： vba compare match move

【解决方案1】：

试试这个以满足您最初的需求：（不确定您的工作表名称是什么，因此您可能需要编辑以反映正确的工作表。）

Sub CompareAndMove()

Dim rng1 As Range, rng2 As Range, i As Long, iL As Long, var As Range, j As Long, ws1 As Worksheet, Chk As Range, LastDest As Long

Set ws1 = Sheets("Sheet1")
iL = ws1.Range("A" & Rows.Count).End(xlUp).Row

For j = 3 To 5
    Set rng2 = ws1.Range(ws1.Cells(2, j), ws1.Cells(ws1.Cells(Rows.Count, j).End(xlUp).Row, j))
    For i = 2 To iL
        Set rng1 = ws1.Range("A" & i)
        Set var = rng2.Find(rng1.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not var Is Nothing Then
            rng1.Interior.Color = RGB(255, 255, 0)
            rng1.Copy
            rng1.Offset(0, 1).PasteSpecial
        End If
    Next i
    ws1.Range("B2:B" & ws1.Range("B" & Rows.Count).End(xlUp).Row).Copy
    LastDest = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet2").Cells(LastDest, 1).PasteSpecial xlPasteValues
    LastDest = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
    Set rng3 = Sheets("Sheet2").Range("A2:A" & LastDest)
    For each Chk in rng3
        If Len(Chk.Value) = 0 Then
            Chk.EntireRow.Delete xlShiftUp
        End If
    Next Chk
    ws1.Range("B:B").Clear
Next j
End Sub

【讨论】：

原始代码工作正常我对其进行了一些更改以取消使用剪贴板，我已经更新了问题中的代码。还阅读您发送的代码，我不确定它是否在做我想要的。我将再次尝试解释，A 列是我的“信号列表”，我应该有所有信号。 J 列是我需要匹配的信号列表。如果 J 列中有一个项目，它是我在 A 列的列表中没有的“新信号”，因此我需要将其添加到此列表中。我不需要从 J 列中删除它我需要 A 列底部的副本

【解决方案2】：

Sub CompareAndMove()

Dim rng1 As Range, rng2 As Range, i As Long, iL As Long, var As Variant

iL = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To iL
    Set rng1 = Sheets("Sheet1").Range("A" & i)
    Set rng2 = Sheets("Sheet1").Range("C:C")


   var = Application.Match(rng1.Value, rng2, 1)

   If Not IsError(Application.Match(rng1.Value, rng2, 0)) Then
   bln = True

   If bln = True Then

                rng1.Interior.Color = RGB(255, 255, 0)
                rng1.Copy
                rng1.Offset(0, 1).PasteSpecial


    End If
    Set rng1 = Nothing
    Set rng2 = Nothing
    End If

Next i

结束子

【讨论】：

【解决方案3】：

Sub CompareAndMove()

Dim rng1 As Range, rng2 As Range, i As Long, iL As Long, var As Range, j As Long, ws1 As Worksheet, rng3 As Range, rng4 As Range, lRows As Long, lRows2 As Long, jL

Set ws1 = Sheets("Comparison Sheet")
Set ws2 = Sheets("Comparison Sheet Final")

iL = ws1.Range("A" & Rows.Count).End(xlUp).Row
jL = ws1.Cells(2, Columns.Count).End(xlToLeft).Column

For j = 3 To jL
    Set rng2 = ws1.Range(ws1.Cells(2, j), ws1.Cells(ws1.Cells(Rows.Count, j).End(xlUp).Row, j))
    For i = 2 To iL
        Set rng1 = ws1.Range("A" & i)
        Set var = rng2.Find(rng1.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not var Is Nothing Then
                    rng1.Interior.Color = RGB(255, 255, 0)
                    rng1.Offset(0, 1).Font.Name = "Wingdings"
                    rng1.Offset(0, 1).Value = ChrW(&HFC)
        End If
     
     Next i
    
    ws1.Cells(2, 2) = ws1.Cells(2, j)
    lRows = ws1.Cells(Rows.Count, "A").End(xlUp).Row
    Set rng3 = ws1.Range(ws1.Cells(2, 2), ws1.Cells(lRows, 2))
    lRows2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
    lCols = j - 1

    Set rng4 = ws2.Range(ws2.Cells(2, lCols), ws2.Cells(lRows, lCols))
    rng4.Font.Name = "Wingdings"
    rng4.Value = rng3.Value
    rng3.ClearContents
    ws2.Rows(2).Font.Name = "Calibri"
    
Next j

End Sub

在您的代码稍作修改后的当前外观

【讨论】：