如何用VBA实现双条件查找并批量迁移Excel数据？

需求说明 #

需要从Python生成的数据源工作表批量提取数据，迁移到已搭建完成的化合物报表工作表，核心步骤如下：

• 在数据源工作表第1行，定位**同时包含_1.D和air blank**的单元格
• 在该单元格所在列，查找指定化合物名称（如Compound 1、Compound 2）
• 找到对应行后，提取该行相邻4列数据，写入到与化合物同名的工作表中，对应到Air Blank行

完整VBA代码 #

' 检查工作表是否存在的辅助函数
Function WorksheetExists(WSName As String) As Boolean
    On Error Resume Next
    WorksheetExists = Worksheets(WSName).Name = WSName
    On Error GoTo 0
End Function

Sub FindAndAddData()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim sourceCol As Integer
    Dim compoundRow As Long
    Dim targetRow As Long
    Dim shname As String
    Dim compoundNames As Variant
    Dim i As Integer
    
    ' 让用户选择数据源工作表
    Do Until WorksheetExists(shname)
        shname = InputBox("请输入数据源工作表名称")
        If StrPtr(shname) = 0 Then
            MsgBox "用户已取消操作！"
            Exit Sub
        ElseIf Not WorksheetExists(shname) Then
            MsgBox shname & " 不存在，请重新输入！", vbExclamation
        End If
    Loop
    Set sourceSheet = Worksheets(shname)
    
    ' 定义需要处理的化合物列表（可根据实际情况修改）
    compoundNames = Array("Compound 1", "Compound 2", "Compound 3")
    
    ' 步骤1：在数据源第1行查找符合条件的列
    For sourceCol = 1 To sourceSheet.Cells(1, sourceSheet.Columns.Count).End(xlToLeft).Column
        If InStr(1, sourceSheet.Cells(1, sourceCol).Value, "_1.D", vbTextCompare) > 0 And _
           InStr(1, sourceSheet.Cells(1, sourceCol).Value, "air blank", vbTextCompare) > 0 Then
            Exit For ' 找到目标列后退出循环
        End If
    Next sourceCol
    
    ' 如果没找到符合条件的列，提示并退出
    If sourceCol > sourceSheet.Cells(1, sourceSheet.Columns.Count).End(xlToLeft).Column Then
        MsgBox "未找到包含'_1.D'和'air blank'的列！", vbCritical
        Exit Sub
    End If
    
    ' 遍历每个化合物，执行数据迁移
    For i = LBound(compoundNames) To UBound(compoundNames)
        ' 检查目标化合物工作表是否存在
        If Not WorksheetExists(compoundNames(i)) Then
            MsgBox compoundNames(i) & " 工作表不存在，跳过该化合物！", vbExclamation
            GoTo NextCompound
        End If
        Set targetSheet = Worksheets(compoundNames(i))
        
        ' 步骤2：在数据源目标列中查找化合物名称
        On Error Resume Next
        compoundRow = sourceSheet.Columns(sourceCol).Find(What:=compoundNames(i), LookIn:=xlValues, LookAt:=xlWhole).Row
        On Error GoTo 0
        
        ' 如果没找到化合物行，提示并跳过
        If compoundRow = 0 Then
            MsgBox "在数据源中未找到 " & compoundNames(i) & "，跳过！", vbExclamation
            GoTo NextCompound
        End If
        
        ' 步骤3：提取相邻4列数据（当前列右侧4列，可根据实际调整）
        sourceSheet.Range(sourceSheet.Cells(compoundRow, sourceCol + 1), sourceSheet.Cells(compoundRow, sourceCol + 4)).Copy
        
        ' 在目标工作表中查找Air Blank行并粘贴数据
        On Error Resume Next
        targetRow = targetSheet.Columns(1).Find(What:="Air Blank", LookIn:=xlValues, LookAt:=xlWhole).Row
        On Error GoTo 0
        
        If targetRow = 0 Then
            MsgBox compoundNames(i) & " 工作表中未找到Air Blank行，跳过！", vbExclamation
            GoTo NextCompound
        End If
        
        ' 粘贴数据到目标行的指定位置（这里默认从第2列开始，可调整）
        targetSheet.Cells(targetRow, 2).PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        
NextCompound:
    Next i
    
    MsgBox "数据迁移完成！", vbInformation
End Sub

代码说明 #

1. 工作表存在性检查：WorksheetExists函数用来避免因工作表不存在导致的运行错误
2. 数据源选择：通过输入框让用户指定数据源工作表，支持取消操作
3. 目标列定位：遍历第1行所有单元格，通过InStr函数匹配包含_1.D和air blank的列
4. 化合物遍历：通过数组定义需要处理的化合物，可根据实际情况修改数组内容
5. 数据提取与写入：
   • 在数据源列中查找化合物名称对应的行
   • 提取该行右侧4列数据（可通过调整sourceCol + 1和sourceCol + 4修改范围）
   • 在目标工作表中找到Air Blank行，粘贴数据（默认从第2列开始，可修改targetSheet.Cells(targetRow, 2)调整位置）

注意事项 #

• 确保化合物名称、Air Blank行的文本与代码中的完全一致，或修改LookAt:=xlWhole为LookAt:=xlPart支持模糊匹配
• 如果数据源中化合物名称所在列不是目标列，可修改sourceSheet.Columns(sourceCol)为对应的列号
• 数据复制范围可根据实际需求调整列数

内容的提问来源于stack exchange，提问作者TechnoWolf150