Excel VBA实现特定文本检索、比对及跨工作表粘贴需求

嘿，我来帮你搞定这个Excel数据处理的需求！针对你提到的从Sheet1提取特定文本、和Sheet2比对后输出到Sheet3的需求，我整理了两种实用方案，分别适配不同Excel版本和数据量：

如果你的Excel支持动态数组函数，用这个方法最快，不需要写代码：

步骤1：在Sheet1提取目标文本 #

在Sheet1的B1单元格输入以下公式，它会自动提取所有以N1*PE*开头、到~N前的完整片段，并纵向排列：

=TOCOL(FILTER(TEXTSPLIT(A1,"~N"),LEFT(TEXTSPLIT(A1,"~N"),6)="N1*PE*"),1)

• 原理：先用TEXTSPLIT把A列内容按~N拆分，再用FILTER筛选出开头是N1*PE*的片段，最后用TOCOL把横向结果转为纵向。
• 如果只需要提取片段末尾的9位数字，把公式改成：

=TOCOL(FILTER(RIGHT(TEXTSPLIT(A1,"~N"),9),LEFT(TEXTSPLIT(A1,"~N"),6)="N1*PE*"),1)

步骤2：和Sheet2比对并输出到Sheet3 #

1. 把Sheet1 B列提取的内容复制到Sheet3的A列；
2. 在Sheet3的B1单元格输入比对公式，下拉填充：

=IF(COUNTIF(Sheet2!A:A,A1)>0,"匹配正确","匹配错误")

这个公式会检查当前单元格内容是否存在于Sheet2的正确列表中，返回对应的匹配结果。

如果Sheet1的数据量极大，或者你用的是旧版Excel（不支持动态数组），用VBA脚本可以高效批量处理：

操作步骤： #

1. 打开你的Excel文件，按Alt+F11打开VBA编辑器；
2. 右键点击左侧的工作簿名称，选择「插入」→「模块」；
3. 把下面的代码粘贴到模块窗口：

Sub ExtractAndCompare()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long, i As Long, j As Long, k As Long
    Dim cellText As String, startPos As Long, endPos As Long, extractText As String
    Dim matchFound As Boolean
    
    ' 绑定三个工作表对象
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    Set ws3 = ThisWorkbook.Sheets("Sheet3")
    
    ' 清空Sheet3原有内容
    ws3.Cells.Clear
    
    ' 获取各表的最后一行数据位置
    lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    
    k = 1 ' Sheet3的起始写入行
    
    ' 遍历Sheet1的每一行数据
    For i = 1 To lastRow1
        cellText = ws1.Cells(i, "A").Value
        startPos = InStr(cellText, "N1*PE*")
        
        ' 循环提取当前单元格内所有符合条件的片段
        Do While startPos > 0
            endPos = InStr(startPos, cellText, "~N")
            If endPos > 0 Then
                ' 提取从N1*PE*到~N前的完整文本
                extractText = Mid(cellText, startPos, endPos - startPos)
                
                ' 检查是否在Sheet2的正确列表中
                matchFound = False
                For j = 1 To lastRow2
                    If ws2.Cells(j, "A").Value = extractText Then
                        matchFound = True
                        Exit For
                    End If
                Next j
                
                ' 写入Sheet3，A列存提取的文本，B列存匹配结果
                ws3.Cells(k, "A").Value = extractText
                ws3.Cells(k, "B").Value = IIf(matchFound, "匹配正确", "匹配错误")
                k = k + 1
                
                ' 查找下一个N1*PE*的位置，继续循环提取
                startPos = InStr(endPos, cellText, "N1*PE*")
            Else
                ' 如果找不到对应的~N，终止当前单元格的提取
                Exit Do
            End If
        Loop
    Next i
    
    MsgBox "处理完成！结果已保存到Sheet3。"
End Sub

4. 按F5运行脚本，等待弹窗提示处理完成即可。

注意：如果你的工作表名称不是Sheet1/Sheet2/Sheet3，记得修改代码里的工作表名称哦！

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