Question

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列。

不幸的是我还不能发布图片，我希望这对于有人支持我来说已经足够清楚了吗？

我已经即兴使用“代码片段来显示数据的外观，假设它们排列在A列和B列中

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

Answer 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

Answer 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

End Sub

Answer 3

＆＃13;

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

＆＃13;

目前看起来如何使用您的代码进行轻微修改

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

3 个答案: