web-dev-qa-db-ja.com

特定のデータをある列から別の列に移動するVBA

以前にこれについてヘルプをリクエストしようとしましたが、役立つ応答がありません。

赤字の単語をリストとして列Aから列Cに移動するマクロ/ VBAが必要です。

ただし、同じ単語が列Aで複数回強調表示されている場合は、文字列でない限り、その単語を列Cに1回だけ入れます（重複はありません）。

私のデータは次のとおりです

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

どこから始めればいいのかわからないので、どんな助けでも本当にありがたいです...

ありがとう

microsoft-excelmicrosoft-excel-2010vbamacros
2
Jez Vander Brown

（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

コード（ActiveSheet.Range().RemoveDuplicates）を追加して、指定された範囲から重複を削除するようにシートに指示できます。アクティブシートにC:Cの範囲を追加すると、列全体がカバーされます。特定の範囲が必要な場合は、必要な特定のセル範囲に変更できます。

共有したコードの最後に追加できる行は次のとおりです。

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