VBA для перемещения данных из одного столбца в другой

Я пытался обратиться за помощью с этим раньше, но не получил никаких полезных ответов.

Мне нужен макрос / VBA, который перемещает любое слово красного цвета из столбца A в столбец C в виде списка.

однако, если одно и то же слово выделено более одного раза в столбце A, я хочу, чтобы это слово входило в столбец C только один раз (без дубликатов), если только это не строка.

мои данные выглядят следующим образом

enter image description here

Я пробовал создать 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

результат, который я получаю, выглядит следующим образом:

enter image description here

чего я хотел бы достичь, так это следующего:

enter image description here

любая помощь будет действительно оценили, как я не знаю, с чего начать...

спасибо

3
задан Jez Vander Brown
15.04.2023 0:02 Количество просмотров материала 2921
Распечатать страницу

2 ответа

вы можете добавить код (ActiveSheet.Range().RemoveDuplicates), чтобы указать листу удалить дубликаты из заданного диапазона. Добавление C:C диапазон на активном листе будет охватывать весь столбец. Если вам нужен определенный диапазон, вы можете изменить его на определенный диапазон ячеек.

вот строка, которую вы можете добавить в конец кода. 

ActiveSheet.Range("C:C").RemoveDuplicates Columns:=1, Header:=xlNo
1
отвечен CharlieRB 2023-04-16 07:50

(ответ 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
1
отвечен Engineer Toast 2023-04-16 10:07

Постоянная ссылка на данную страницу: [ Скопировать ссылку | Сгенерировать QR-код ]

Ваш ответ

Опубликуйте как Гость или авторизуйтесь

Имя
Мы используем cookie. Это позволяет нам анализировать взаимодействие посетителей с сайтом и делать его лучше. Продолжая пользоваться сайтом, вы соглашаетесь с использованием файлов cookie. Политика конфиденциальности
Согласен
Вверх