VBA複製粘貼字符串搜索

Question

我似乎無法弄清楚如何編寫一個vba代碼，通過單元格搜索C10：G10找到一個等於單元格A10的匹配，一旦找到，將範圍A14：A18複製到匹配的單元格但低於例如F14：F18（參見圖片）

宏下面

'Copy 
Range("A14:A18").Select 
Selection.Copy 
'Paste 
Range("F14:F18").Select 
ActiveSheet.Paste! 

Answer 1

Dim RangeToSearch As Range 
Dim ValueToSearch 
Dim RangeToCopy As Range 
Set RangeToSearch = ActiveSheet.Range("C10:G10") 
Set RangeToCopy = ActiveSheet.Range("A14:A18") 

ValueToSearch = ActiveSheet.Cells(10, "A").Value 
For Each cell In RangeToSearch 
    If cell.Value = ValueToSearch Then 
     RangeToCopy.Select 
     Selection.Copy 
     Range(ActiveSheet.Cells(14, cell.Column), _ 
      ActiveSheet.Cells(18, cell.Column)).Select 
     ActiveSheet.Paste 
     Application.CutCopyMode = False 
     Exit For 
    End If 
Next cell 

Answer 2

嘗試這種情況：

With Sheets("SheetName") ' Change to your actual sheet name 
    Dim r As Range: Set r = .Range("C10:G10").Find(.Range("A10").Value2, , , xlWhole) 
    If Not r Is Nothing Then r.Offset(4, 0).Resize(5).Value2 = .Range("A14:A18").Value2 
End With 

範圍對象有Find Method可幫助您查找範圍內的值。
然後返回與您的搜索條件匹配的Range對象。
要將您的值轉到正確的位置，只需使用Offset and Resize Method即可。

EDIT1：要回答OP的評論

要查找公式範圍，則需要LookIn參數設置爲xlFormulas。

Set r = .Range("C10:G10").Find(What:=.Range("A10").Formula, _ 
           LookIn:=xlFormulas, _ 
           LookAt:=xlWhole) 

上面的代碼找到與單元格A10具有完全相同公式的範圍。

Answer 3

另一附加變體

1.使用For each環

Sub test() 
Dim Cl As Range, x& 

For Each Cl In [C10:G10] 
    If Cl.Value = [A10].Value Then 
     x = Cl.Column: Exit For 
    End If 
Next Cl 

If x = 0 Then 
    MsgBox "'" & [A10].Value & "' has not been found in range 'C10:G10'!" 
    Exit Sub 
End If 

Range(Cells(14, x), Cells(18, x)).Value = [A14:A18].Value 

End Sub 

2.使用Find方法（已經張貼由L42，但有一點不同）

Sub test2() 
Dim Cl As Range, x& 

On Error Resume Next 

x = [C10:G10].Find([A10].Value2, , , xlWhole).Column 

If Err.Number > 0 Then 
    MsgBox "'" & [A10].Value2 & "' has not been found in range 'C10:G10'!" 
    Exit Sub 
End If 

[A14:A18].Copy Range(Cells(14, x), Cells(18, x)) 

End Sub 

3，採用WorksheetFunction.Match

Sub test2() 
Dim Cl As Range, x& 

On Error Resume Next 

x = WorksheetFunction.Match([A10], [C10:G10], 0) + 2 

If Err.Number > 0 Then 
    MsgBox "'" & [A10].Value2 & "' has not been found in range 'C10:G10'!" 
    Exit Sub 
End If 

[A14:A18].Copy Range(Cells(14, x), Cells(18, x)) 

End Sub 

Answer 4

在這裏你去，

Sub DoIt() 
    Dim rng As Range, f As Range 
    Dim Fr As Range, Crng As Range 

    Set Fr = Range("A10") 
    Set Crng = Range("A14:A18") 
    Set rng = Range("C10:G19") 
    Set f = rng.Find(what:=Fr, lookat:=xlWhole) 

    If Not f Is Nothing Then 
     Crng.Copy Cells(14, f.Column) 
    Else: MsgBox "Not Found" 
     Exit Sub 
    End If 
End Sub