查找文本并将相邻单元格复制到不同的工作表

Sub CopyAdjacentCells()
    Dim searchText As String
    Dim searchRange As Range
    Dim cell As Range
    Dim destinationSheet As Worksheet
    Dim newRow As Long
    
    ' 设置要查找的文本
    searchText = "要查找的文本"
    
    ' 设置要查找的范围，可以是整个工作表或特定的单元格范围
    Set searchRange = ThisWorkbook.Worksheets("Sheet1").Range("A1:A10")
    
    ' 创建一个新的工作表作为目标工作表
    Set destinationSheet = ThisWorkbook.Worksheets.Add
    destinationSheet.Name = "结果"
    
    ' 在目标工作表中添加标题行
    destinationSheet.Range("A1").Value = "文本"
    destinationSheet.Range("B1").Value = "相邻单元格"
    
    ' 遍历查找范围中的每个单元格
    newRow = 2 ' 从第二行开始添加数据
    For Each cell In searchRange
        ' 检查单元格的值是否包含要查找的文本
        If InStr(1, cell.Value, searchText, vbTextCompare) > 0 Then
            ' 将文本和相邻单元格的值复制到目标工作表中
            destinationSheet.Range("A" & newRow).Value = cell.Value
            destinationSheet.Range("B" & newRow).Value = cell.Offset(0, 1).Value
            newRow = newRow + 1 ' 移动到下一行
        End If
    Next cell
    
    ' 调整目标工作表的列宽
    destinationSheet.Columns("A:B").AutoFit
    
    ' 提示查找完成
    MsgBox "查找完成！结果已复制到新的工作表中。"
End Sub