网站 › 『编程语言讨论求助区』 › VBA提取两列部分相同内容

yeyazi520 发表于 2024-9-23 10:51

VBA提取两列部分相同内容

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

wdpjplc 发表于 2024-9-23 10:51

这个也可以啊
要在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 发表于 2024-9-23 13:30

本帖最后由 fuxingjun674 于 2024-9-23 14:21 编辑

chatGPT 回答的！！希望能解决你的要求！
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 发表于 2024-9-23 13:32

这么牛的？

xiugou 发表于 2024-9-23 13:49

很少用VB了， 确实很强。:lol

kingc138 发表于 2024-9-23 15:19

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

kingc138 发表于 2024-9-23 15:20

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

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

fuxingjun674 发表于 2024-9-23 15:32

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

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

yeyazi520 发表于 2024-9-25 10:52

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

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

wdpjplc 发表于 2024-9-25 11:05

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

查看完整版本: VBA提取两列部分相同内容