VBA实现：在附注工作表查找关键词并精准复制内容至校验工作表

好的，我明白你的需求了。下面是一个VBA脚本，可以帮助你在Excel中完成这个任务。请确保你已经启用了Excel的开发工具选项卡，以便插入和运行VBA代码。 ```vba Sub FindAndCopyDerivatives() Dim wsSource As Worksheet Dim wsTarget As Worksheet Dim keyword1 As String, keyword2 As String, keyword3 As String Dim keywordRange As Range Dim startRow As Long, endRow As Long, copyRow As Long Dim targetRow1 As Long, targetRow2 As Long, targetRow3 As Long, targetRow4 As Long Dim foundKeyword1 As Range, foundKeyword2 As Range, foundKeyword3 As Range Dim foundTotal1 As Range, foundTotal2 As Range ' 设置工作表 Set wsSource = ThisWorkbook.Sheets("附注") Set wsTarget = ThisWorkbook.Sheets("附注校验") ' 设置关键词 keyword1 = "利率衍生工具" keyword2 = "权益衍生工具" keyword3 = "其他衍生工具" ' 初始化目标行 targetRow1 = 149 targetRow2 = 154 targetRow3 = 159 targetRow4 = 163 ' 查找关键词 Set foundKeyword1 = wsSource.Columns(1).Find(What:=keyword1, LookIn:=xlValues, LookAt:=xlWhole) Set foundKeyword2 = wsSource.Columns(1).Find(What:=keyword2, LookIn:=xlValues, LookAt:=xlWhole) Set foundKeyword3 = wsSource.Columns(1).Find(What:=keyword3, LookIn:=xlValues, LookAt:=xlWhole) ' 处理找到的关键词 If Not foundKeyword1 Is Nothing Then Call ProcessKeyword(foundKeyword1, wsSource, wsTarget, targetRow1, targetRow4) End If If Not foundKeyword2 Is Nothing Then Call ProcessKeyword(foundKeyword2, wsSource, wsTarget, targetRow2, targetRow4) End If If Not foundKeyword3 Is Nothing Then Call ProcessKeyword(foundKeyword3, wsSource, wsTarget, targetRow3, targetRow4) End If ' 在合计行下方重新查找关键词 If Not foundTotal1 Is Nothing Then Set keywordRange = wsSource.Range(wsSource.Cells(foundTotal1.Row + 1, 1), wsSource.Cells(wsSource.Rows.Count, 1)) Set foundKeyword1 = keywordRange.Find(What:=keyword1, LookIn:=xlValues, LookAt:=xlWhole) Set foundKeyword2 = keywordRange.Find(What:=keyword2, LookIn:=xlValues, LookAt:=xlWhole) Set foundKeyword3 = keywordRange.Find(What:=keyword3, LookIn:=xlValues, LookAt:=xlWhole) If Not foundKeyword1 Is Nothing Then Call ProcessKeyword(foundKeyword1, wsSource, wsTarget, 174, 188) End If If Not foundKeyword2 Is Nothing Then Call ProcessKeyword(foundKeyword2, wsSource, wsTarget, 179, 188) End If If Not foundKeyword3 Is Nothing Then Call ProcessKeyword(foundKeyword3, wsSource, wsTarget, 184, 188) End If End If End Sub Sub ProcessKeyword(keywordCell As Range, wsSource As Worksheet, wsTarget As Worksheet, targetRow1 As Long, targetRow4 As Long) Dim startRow As Long, endRow As Long, copyRow As Long Dim foundTotal As Range startRow = keywordCell.Row Set foundTotal = wsSource.Range(wsSource.Cells(startRow, 1), wsSource.Cells(wsSource.Rows.Count, 1)).Find(What:="合计", LookIn:=xlValues, LookAt:=xlWhole) endRow = foundTotal.Row - 1 For copyRow = startRow To endRow wsSource.Range(wsSource.Cells(copyRow, 1), wsSource.Cells(copyRow, 7)).Copy wsTarget.Cells(targetRow1, 1).PasteSpecial Paste:=xlPasteValues targetRow1 = targetRow1 + 1 Next copyRow wsSource.Range(wsSource.Cells(foundTotal.Row, 1), wsSource.Cells(foundTotal.Row, 7)).Copy wsTarget.Cells(targetRow4, 1).PasteSpecial Paste:=xlPasteValues End Sub ``` 需要注意的逻辑点： 1. 关键词查找范围：确保关键词查找的范围正确，特别是在合计行下方重新查找时，避免重复查找。 2. 合计行的唯一性：假设每个关键词下方只有一个合计行，如果有多行合计，需要进一步处理。 3. 目标单元格的更新：确保目标单元格的行号在每次复制后正确更新，避免覆盖已有的数据。 希望这个脚本能帮到你！如果有任何问题或需要进一步调整，请告诉我。 ######[AI写代码神器 | 1106点数解答 | 2024-12-18 14:32:49]