VBA 精准查找关键词并复制数据至指定位置：附代码及注意要点

以下是使用 VBA 实现上述功能的代码： ```vb Sub FindAndCopyData() Dim wsOriginal As Worksheet Dim wsVerify As Worksheet Dim keyword1 As String Dim keyword2 As String Dim keyword3 As String Dim found1 As Boolean Dim found2 As Boolean Dim found3 As Boolean Dim row1 As Long Dim row2 As Long Dim row3 As Long Dim totalRow1 As Long Dim totalRow2 As Long Dim totalRow3 As Long Dim i As Long Set wsOriginal = Worksheets("w附注工作表") Set wsVerify = Worksheets("附注校验工作表") keyword1 = "利率衍生工具" keyword2 = "权益衍生工具" keyword3 = "其他衍生工具" found1 = False found2 = False found3 = False ' 查找关键词 For i = 1 To wsOriginal.Rows.Count If InStr(1, wsOriginal.Cells(i, 1).Value, keyword1) > 0 Then found1 = True row1 = i End If If InStr(1, wsOriginal.Cells(i, 1).Value, keyword2) > 0 Then found2 = True row2 = i End If If InStr(1, wsOriginal.Cells(i, 1).Value, keyword3) > 0 Then found3 = True row3 = i End If Next i ' 定位关键词下方的第一个合计行 If found1 Then For i = row1 + 1 To wsOriginal.Rows.Count If InStr(1, wsOriginal.Cells(i, 1).Value, "合计") > 0 Then totalRow1 = i Exit For End If Next i End If If found2 Then For i = row2 + 1 To wsOriginal.Rows.Count If InStr(1, wsOriginal.Cells(i, 1).Value, "合计") > 0 Then totalRow2 = i Exit For End If Next i End If If found3 Then For i = row3 + 1 To wsOriginal.Rows.Count If InStr(1, wsOriginal.Cells(i, 1).Value, "合计") > 0 Then totalRow3 = i Exit For End If Next i End If ' 复制数据 If found1 Then wsOriginal.Range("A" & row1 & ":G" & row1).Copy wsVerify.Range("A149").PasteSpecial xlPasteValues If found2 And row2 > row1 Then wsOriginal.Range("A" & row2 & ":G" & row2).Copy wsVerify.Range("A154").PasteSpecial xlPasteValues End If If found3 And row3 > row2 Then wsOriginal.Range("A" & row3 & ":G" & row3).Copy wsVerify.Range("A159").PasteSpecial xlPasteValues End If wsOriginal.Range("A" & totalRow1 & ":G" & totalRow1).Copy wsVerify.Range("A163").PasteSpecial xlPasteValues End If If found2 And Not found1 Then wsOriginal.Range("A" & row2 & ":G" & row2).Copy wsVerify.Range("A154").PasteSpecial xlPasteValues If found3 And row3 > row2 Then wsOriginal.Range("A" & row3 & ":G" & row3).Copy wsVerify.Range("A159").PasteSpecial xlPasteValues End If wsOriginal.Range("A" & totalRow2 & ":G" & totalRow2).Copy wsVerify.Range("A163").PasteSpecial xlPasteValues End If If found3 And Not found1 And Not found2 Then wsOriginal.Range("A" & row3 & ":G" & row3).Copy wsVerify.Range("A159").PasteSpecial xlPasteValues wsOriginal.Range("A" & totalRow3 & ":G" & totalRow3).Copy wsVerify.Range("A163").PasteSpecial xlPasteValues End If ' 在合计行下方重新查找 found1 = False found2 = False found3 = False For i = totalRow1 + 1 To wsOriginal.Rows.Count If InStr(1, wsOriginal.Cells(i, 1).Value, keyword1) > 0 Then found1 = True row1 = i End If If InStr(1, wsOriginal.Cells(i, 1).Value, keyword2) > 0 Then found2 = True row2 = i End If If InStr(1, wsOriginal.Cells(i, 1).Value, keyword3) > 0 Then found3 = True row3 = i End If Next i If found1 Then For i = row1 + 1 To wsOriginal.Rows.Count If InStr(1, wsOriginal.Cells(i, 1).Value, "合计") > 0 Then totalRow1 = i Exit For End If Next i End If If found2 Then For i = row2 + 1 To wsOriginal.Rows.Count If InStr(1, wsOriginal.Cells(i, 1).Value, "合计") > 0 Then totalRow2 = i Exit For End If Next i End If If found3 Then For i = row3 + 1 To wsOriginal.Rows.Count If InStr(1, wsOriginal.Cells(i, 1).Value, "合计") > 0 Then totalRow3 = i Exit For End If Next i End If ' 复制数据 If found1 Then wsOriginal.Range("A" & row1 & ":G" & row1).Copy wsVerify.Range("A174").PasteSpecial xlPasteValues If found2 And row2 > row1 Then wsOriginal.Range("A" & row2 & ":G" & row2).Copy wsVerify.Range("A179").PasteSpecial xlPasteValues End If If found3 And row3 > row2 Then wsOriginal.Range("A" & row3 & ":G" & row3).Copy wsVerify.Range("A184").PasteSpecial xlPasteValues End If wsOriginal.Range("A" & totalRow1 & ":G" & totalRow1).Copy wsVerify.Range("A188").PasteSpecial xlPasteValues End If If found2 And Not found1 Then wsOriginal.Range("A" & row2 & ":G" & row2).Copy wsVerify.Range("A179").PasteSpecial xlPasteValues If found3 And row3 > row2 Then wsOriginal.Range("A" & row3 & ":G" & row3).Copy wsVerify.Range("A184").PasteSpecial xlPasteValues End If wsOriginal.Range("A" & totalRow2 & ":G" & totalRow2).Copy wsVerify.Range("A188").PasteSpecial xlPasteValues End If If found3 And Not found1 And Not found2 Then wsOriginal.Range("A" & row3 & ":G" & row3).Copy wsVerify.Range("A184").PasteSpecial xlPasteValues wsOriginal.Range("A" & totalRow3 & ":G" & totalRow3).Copy wsVerify.Range("A188").PasteSpecial xlPasteValues End If End Sub ``` 额外需要注意的逻辑点： 1. 确保要操作的工作表名称准确无误，避免因名称错误导致操作错误的工作表。 2. 处理可能出现的找不到关键词或合计行的情况，添加适当的错误处理代码，避免程序崩溃。 3. 考虑数据量较大时的性能问题，优化查找和复制的算法。 ######[AI写代码神器 | 1928点数解答 | 2024-12-18 14:43:55]