☰

VBA将特定数据从一列移动到另一列

tag-icon • tag-icon microsoft-excel microsoft-excel-2010 vba macros
VBA将特定数据从一列移动到另一列

我之前曾尝试就此寻求帮助，但没有收到任何有用的答复。

我需要一个宏/VBA，将 A 列中的任何红色单词作为列表移动到 C 列。

但是，如果同一个单词在 A 列中突出显示多次，我只希望该单词进入 C 列一次（不重复），除非它是一个字符串。

我的数据如下

在此处输入图片描述

我曾尝试为此创建一个 vba（如下），但它没有按照我希望的方式工作......

Sub copy_red()
Dim LastRow  As Long, x As Long, y As Long, txt1 As String, txt As String
LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For x = 1 To LastRow
    txt1 = ""
    txt = Cells(x, 1)
    If txt <> "" Then
        For y = Len(txt) To 1 Step -1
            If Cells(x, 1).Characters(Start:=y, Length:=1).Font.Color = 255 Then
                txt1 = Cells(x, 1).Characters(Start:=y, Length:=1).Text & txt1
            End If
        Next y
        Cells(x, 3) = txt1
    End If
Next x
End Sub

我得到的结果如下：

在此处输入图片描述

我想要实现的目标如下：

在此处输入图片描述

任何帮助都将不胜感激，因为我不知道从哪里开始......

谢谢

答案1

您可以添加代码（ActiveSheet.Range().RemoveDuplicates）来告诉工作表从给定的范围内删除重复项。C:C在活动工作表中添加范围将覆盖整个列。如果您需要特定范围，可以将其更改为所需的特定单元格范围。

您可以将此行添加到您共享的代码的末尾。

ActiveSheet.Range("C:C").RemoveDuplicates Columns:=1, Header:=xlNo

答案2

（CharlieRB 的答案包含在这里，因为他比我早 1.3 年发布了答案）
您仍然缺少的部分是将同一单元格中的多个红色短语拆分为列表中的多个条目。这是因为您直到浏览完单元格中的所有文本后才将短语放入列表中。您需要在循环中内置一个转义符，以便在FOR红色文本后点击黑色文本时存储结果，并在末尾放置一个转义符（以防最后一个字符是红色）

Sub copy_red()
    Dim LastRow As Long, x As Long, y As Long, txt1 As String, txt As String
    Dim copyRow As Long
    copyRow = 1
    LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    For x = 1 To LastRow
        txt1 = ""
        txt = Cells(x, 1)
        If txt <> "" Then
            For y = 1 To Len(txt)
                If Cells(x, 1).Characters(Start:=y, Length:=1).Font.Color = 255 Then
                    txt1 = txt1 & Cells(x, 1).Characters(Start:=y, Length:=1).Text
                Else
                    If txt1 <> "" Then
                        Cells(copyRow, 3) = txt1
                        copyRow = copyRow + 1
                        txt1 = ""
                    End If
                End If
            Next y
            If txt1 <> "" Then
                Cells(copyRow, 3) = txt1
                copyRow = copyRow + 1
                txt1 = ""
            End If
        End If
    Next x
    ActiveSheet.Range("C:C").RemoveDuplicates Columns:=1, Header:=xlNo
    ActiveSheet.Range("C:C").Font.Color = RGB(255, 0, 0)
End Sub

相关内容