将A列与C列进行比较，将匹配的单元格从位置移动到对应行的B列 [英] Compare column A with column C, Move matching Cell from location to column B on corresponding row

问题描述

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中的数据进行比较

I am trying to compare the data column A with the data in column C

无论如何，如果存在匹配项，我将需要将单元格从C列移至相应行的B列.

However the challenge is , If there is a match I will then need to move the cell from column C to column B on the corresponding row.

不幸的是我还不能发布图片，我希望这足够清晰，可以有人支持我吗?

Unfortunately I can not post pictures yet, I hope this is clear enough for someone to support me with?

我已经临时使用代码段"来显示数据的外观，前提是它们被排列在A B和C列中.

I have improvised to use the "code snippet to display how the data should look assuming they are arranged in Columns A B and 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

推荐答案

尝试执行此操作以达到您的原始需求:(不确定工作表名称是什么，因此您可能需要进行编辑以反映正确的工作表.)

Try this to get to your original need: (Not sure what your sheet names are so you might need to edit to reflect correct sheet.)

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列与C列进行比较，将匹配的单元格从位置移动到对应行的B列的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！