比較列A與列C，從位置移動匹配節至B列上相應的行

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 \t \t A12352 
 
A12335 \t \t A12353 
 
A12336 \t \t A12339 
 
A12337 \t \t A12340 
 
A12338 \t \t A12341 
 
A12339 \t \t A12354 
 
A12340 \t \t A12355 
 
A12341 \t \t A12356 
 
A12342 \t \t A22354 
 
A12343 \t \t A22356 
 
A12344 \t \t A22358 
 
A12345 \t \t A22360 
 
A12346 \t \t A22362 
 
A12347 \t \t A22364 
 
A12348 \t \t A22366 
 
A12349 \t \t A22368 
 
A12350 \t \t A22370 
 
A12351 \t \t A22372 
 
A12352 \t \t A12357 
 
A12353 \t \t A12358 
 
A12354 \t \t A12334 
 
A12355 \t \t A12335 
 
A12356 \t \t A12336 
 
A12357 \t \t A12337 
 
A12358 \t \t A12338 
 
A12359 \t \t A22370 
 
A12360 \t \t A22372 
 
A12361 \t \t A12361 
 

 
After: 
 

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

來源

2014-12-02 Samatar

你試過到目前爲止什麼代碼代碼？ SO不是一個代碼外包平臺。你需要分享你已經嘗試過的東西以及你被困住的地方。 http://stackoverflow.com/help/on-topic – Chrismas007 2014-12-02 14:33:34

嗨，我已經添加了一個腳本，我以前做了一個更簡單的任務，並使用StrComp，但我沒有嘗試使用MATCH函數，因爲我需要知道細胞的位置，以移動它（這是我的承擔如何解決）第二個是我迄今爲止的嘗試，我已經改變了很多，目前沒有什麼。一個正確的方向將是非常受歡迎的！（道歉沒有添加代碼之前，我沒有指望有人編寫代碼，但讓我走上正軌！） – Samatar 2014-12-02 14:57:36

試試這個到你原來需要:(不知道你的工作表名稱是什麼，所以你可能需要編輯以反映正確的工作表。）

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

來源

2014-12-02 15:11:43 Chrismas007

原始代碼正常工作我做了一些更改以取消剪貼板的使用，我更新了代碼在問題中。同時閱讀你發送的代碼，我不確定它正在做我想要的。我會再試一次解釋，列A是我的「信號列表」，我應該有所有的信號。列J是我需要匹配的信號列表。如果J列中的項目有一個「新信號」，我沒有列入列A的列表中，因此我需要將它添加到此列表中。我不需要從列J刪除它我需要在列A底部的副本 – Samatar 2014-12-11 08:11:43

Sub CompareAndMo VE（）

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

末次

來源

2014-12-03 15:26:03 Samatar

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

目前它的外觀與輕微的編輯

來源

2014-12-09 15:47:34 Samatar

比較列A與列C，從位置移動匹配節至B列上相應的行

回答

相關問題