比较列A与列C，从位置移动匹配节至B列上相应的行(Compare column A with col

 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列的相应行。

不幸的是我不能发布图片，我希望这是足够清晰的人来支持我？

我已经即兴使用“代码片段中显示的数据看起来应该假设他们被安排在列AB和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 

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:

子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

结束小组

Answer 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 

它是如何目前看起来与轻微修改代码

文章来源: Compare column A with column C, Move matching Cell from location to column B on corresponding row