如何find一个string关键字，并将string匹配时粘贴到它下面的行？

我对VBA很新。 我正在尝试编写一个macros，它将在所有标题名称（第1行中的所有variables名称）中search单词“date”，并将单元格（从另一个表格）复制到标题下find匹配项的行（第2行）。

粘贴部分目前不工作，我正在search整个工作簿，因为我不知道如何设置它只search标题行。

Sub FindAndPaste() Dim Sheet As Worksheet Dim Loc As Range For Each Sheet In ThisWorkbook.Worksheets With Sheet.UsedRange Set Loc = .Cells.Find(What:="date") If Not Loc Is Nothing Then Do Until Loc Is Nothing Sheets("Sheet1").Range("L3").Copy Loc.Value.Offset(1, 0).PasteSpecial xlPasteAll Set Loc = .FindNext(Loc) Loop End If End With Set Loc = Nothing Next End Sub 

我也尝试通过改变它到下面的代码来改变Do Until循环内部的部分，但似乎也没有工作。

 Do Until Loc Is Nothing copiedval = Sheets("Sheet1").Range("L3").Copy Loc.Value.Offset(1, 0).Value = copiedval Set Loc = .FindNext(Loc) Loop 

Answer 1

这将更直接，而不使用Find（）

目前还不清楚你是在寻找包含date的单元格，还是只有值为“date”的单元格。

或者是否要从search中排除Sheet1

 Sub FindAndPaste() Dim Sheet, wb As workbook Dim c As Range, arrSheets Set wb = ThisWorkbook arrSheets = Array(wb.sheets("Sheet2"), wb.sheets("Sheet3")) For Each Sheet In arrSheets For Each c in Sheet.UsedRange.Rows(1).Cells If c.value like "*date*" Then wb.Sheets("Sheet1").Range("L3").Copy c.Offset(1,0) c.Offset(1,0).NumberFormat = "yyyy/mm/dd" '<<<<<<<<<EDIT End If Next c Next End Sub 

Answer 2

尝试这个

 Sub FindAndPaste() Dim sht As Worksheet Dim Loc As Range, founds As Range Dim firstAddress As String For Each sht In ThisWorkbook.Worksheets Set founds = sht.Cells(2,1) With Intersect(sht.Rows(1), sht.UsedRange) Set Loc = .Find(What:="date", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False) If Not Loc Is Nothing Then firstAddress = Loc.Address Do Set founds = Union(founds, Loc) Set Loc = .FindNext(Loc) Loop While Not Loc.Address <>firstAddress Intersect(.Cells,founds).Offset(1).Value =Sheets("Sheet1").Range("L3").Value End If End With Next sht End Sub 

而如果你需要find一个包含“date”的头，而不是用LookAt:=xlWholereplaceLookAt:=xlWhole LookAt:=xlPart