VBA提取两列部分相同内容

yeyazi520

求助VBA提取两列部分相同内容，需要提取两列中相同文字，或者高亮显示两列中相同的文字，谢谢大佬。

wdpjplc

这个也可以啊
要在Excel中使用VBA提取两列中的相同内容或高亮显示相同的文字，可以使用以下代码。这个代码会比较两列中的每个单元格，并在第三列显示相同的内容，或者高亮显示相同的单元格。

### 提取两列中相同的内容

```vba
Sub ExtractCommonValues()
    Dim ws As Worksheet
    Dim rngA As Range, rngB As Range, cellA As Range, cellB As Range
    Dim result As Range
    Dim dict As Object
   
    Set ws = ThisWorkbook.Sheets("Sheet1") ' 修改为你的工作表名称
    Set rngA = ws.Range("A1:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
    Set rngB = ws.Range("B1:B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row)
    Set result = ws.Range("C1") ' 结果输出到C列
    Set dict = CreateObject("Scripting.Dictionary")
   
    ' 将A列内容添加到字典
    For Each cellA In rngA
        If Not dict.exists(cellA.Value) Then
            dict.Add cellA.Value, 1
        End If
    Next cellA
   
    ' 检查B列内容是否在字典中
    For Each cellB In rngB
        If dict.exists(cellB.Value) Then
            result.Value = cellB.Value
            Set result = result.Offset(1, 0)
        End If
    Next cellB
End Sub
```

### 高亮显示两列中相同的内容

```vba
Sub HighlightCommonValues()
    Dim ws As Worksheet
    Dim rngA As Range, rngB As Range, cellA As Range, cellB As Range
   
    Set ws = ThisWorkbook.Sheets("Sheet1") ' 修改为你的工作表名称
    Set rngA = ws.Range("A1:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
    Set rngB = ws.Range("B1:B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row)
   
    ' 清除之前的高亮
    rngA.Interior.ColorIndex = xlNone
    rngB.Interior.ColorIndex = xlNone
   
    ' 比较两列并高亮相同的单元格
    For Each cellA In rngA
        For Each cellB In rngB
            If cellA.Value = cellB.Value And cellA.Value <> "" Then
                cellA.Interior.Color = RGB(255, 255, 0) ' 黄色高亮
                cellB.Interior.Color = RGB(255, 255, 0) ' 黄色高亮
            End If
        Next cellB
    Next cellA
End Sub
```

### 使用方法
1. 打开Excel并按 `Alt + F11` 进入VBA编辑器。
2. 插入一个新模块 (`Insert > Module`)。
3. 将上述代码复制并粘贴到模块中。
4. 关闭VBA编辑器并返回Excel。
5. 按 `Alt + F8` 打开宏对话框，选择相应的宏 (`ExtractCommonValues` 或 `HighlightCommonValues`)，然后点击“运行”。

希望这些代码能帮到你！如果有任何问题或需要进一步的帮助，请随时告诉我。&#128522;

fuxingjun674

chatGPT 回答的！！希望能解决你的要求！

[Asm] 纯文本查看 复制代码

Sub ExtractMatchingValues()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim dict As Object
    Dim col1 As Range, col2 As Range
    Dim resultCol As Range
    Dim value As Variant

    Set ws = ThisWorkbook.Sheets("Sheet1") ' 修改为你要操作的工作表名称
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' 假设数据从第一列开始，可以根据实际情况修改

    ' 将两列存放到 Range 对象中
    Set col1 = ws.Range("A1:A" & lastRow) ' 第一列的范围
    Set col2 = ws.Range("B1:B" & lastRow) ' 第二列的范围

    ' 创建一个字典用于存放相同的数值
    Set dict = CreateObject("Scripting.Dictionary")

    ' 创建一个新列来存放结果
    Set resultCol = ws.Cells(1, 3)  ' 放到第三列，可以根据实际情况修改

    ' 遍历第一列，将值存放到字典中
    For i = 1 To lastRow
        dict(col1.Cells(i, 1).Value) = True
    Next i

    ' 遍历第二列，如果值在字典中存在，则写入到新列中
    For i = 1 To lastRow
        If dict.Exists(col2.Cells(i, 1).Value) Then
            resultCol.Cells(i, 1).Value = col2.Cells(i, 1).Value
        End If
    Next i

    ' 释放对象
    Set dict = Nothing
    Set resultCol = Nothing
    Set col1 = Nothing
    Set col2 = Nothing
    Set ws = Nothing
End Sub

zengyi2020

这么牛的？

xiugou

很少用VB了， 确实很强。

kingc138

有没有模板发个过来，要达成什么效果在模板里面标注清楚。

kingc138

fuxingjun674 发表于 2024-9-23 13:30
chatGPT 回答的！！希望能解决你的要求！
[mw_shl_code=asm,true]Sub ExtractMatchingValues()
    Dim w ...

有没有调试一下？能不能正常运行，

fuxingjun674

kingc138 发表于 2024-9-23 15:20
有没有调试一下？能不能正常运行，

当然有调式过
解决第一，二列相同内容的，提取至第三列

yeyazi520

wdpjplc 发表于 2024-9-23 18:24
这个也可以啊
要在Excel中使用VBA提取两列中的相同内容或高亮显示相同的文字，可以使用以下代码。这个代码 ...

好像提示出错了，是不是那一步不对呢

wdpjplc

这个是对比的sheet1 中a列和和b列的内容 一个提取到c列中 另一个是高亮a列中重复的，我用的2016 office测试正常，你用的什么版本？ 可以调试看看哪一步出错了？ 确保a列和b列中有数据