VBAで色文字を検索して指定列に表示させたい

Question

VBA初心者です。

EXCEL（2016）で添付のようにC列に文字が入っており、抽出ボタンを押すとC列の色文字部分だけE~G列に表示させたいのですが、手法がわかりません。

要件としては
1つの行に複数の色文字があった場合は別の列に表示させます。
ただし、「きく」のように色文字がつながっている場合は1つの単語として表示させたいです。

知見をお持ちの方、記述方法のサンプル等をいただけると助かります。

お手数ですがご教示のほどお願いします。

Comments

[退会済みユーザー]

コードの書き方が全く分からないということでしょうか。このままでは丸投げです。文字の着色操作はマクロの記録で取得できるので、まずはそこから頑張って書いてみましょう。

[退会済みユーザー]

あとは、どういう手順でプログラムを書いたらできそうか、日本語で良いので書き出して見ると良いと思います。

[bonbaye]

すみません。私エンジニアでもなく全くの初心者でして、いくつかググってみましたが、コードの書き方自体もわかっていない状況のためこのような質問をさせていただきました。。

Answer 1

A1セルの中身を一文字ずつ調べるコードを書いておきます。
あとは応用したコードを作って試してみて下さい。

Sub test1()
    Dim targSheet As Worksheet: Set targSheet = ThisWorkbook.Worksheets("Sheet1")
    Dim A1Range As Range: Set A1Range = targSheet.Range("A1")
    
    Dim icount
    Dim char
    For icount = 1 To Len(A1Range.Value)
        Set char = A1Range.Characters(icount, 1)
    Next
End Sub

Comments

[TanakaHiroaki]

一文字ずつ調べる方法があるのですね。すごいです。
下記を追加してステップ実行することで理解が深まりました。
Debug.Print char.Font.Color

Answer 2

一応1日経ったので、そろそろ頭が沸騰してきたことに期待して完成形の例など。

Option Explicit

Sub カラー抽出()
    Const rgb As Long = 255 '赤色(255,0,0)
    
    Dim SH As Worksheet
    Dim R As Range
    Dim C As Characters
    Dim i As Long, j As Long, k As Long
    
    '直前の検査結果がrgbと一致したかを保持するフラグ
    Dim isRgb As Boolean
    
    'とりあえず10行、5列（最大文字数分メモリを確保する）
    Dim Data(1 To 10, 1 To 5) As Variant
    
    Set SH = ActiveSheet
    
    'メインループ
    For i = 1 To 10
        'Rangeオブジェクト：C2からとりあえず10行
        Set R = SH.Range("C2").Offset(i - 1, 0)
        j = 0
        isRgb = False
        If Len(R.Value) > 0 Then
            For k = 1 To R.Characters.Count
                'キャラクタオブジェクト：先頭から1字づつ
                Set C = R.Characters(k, 1)
                'Debug.Print C.Font.Color
                
                If (k = 1) Or (isRgb <> (C.Font.Color = rgb)) Then
                    '初回 or 直前とisRgbが逆
                    isRgb = (C.Font.Color = rgb)
                    '色が一致している時のみインデックス移動して代入
                    If isRgb Then j = j + 1: Data(i, j) = C.Text
                Else
                    '直前とisRgbが同じ
                    isRgb = (C.Font.Color = rgb)
                    '色が一致している時のみ追記
                    If isRgb Then Data(i, j) = Data(i, j) & C.Text
                End If
            Next
        End If
    Next
    
    '書き出し
    SH.Range("E2").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
End Sub

一応teratailはエンジニア向けのサービスらしいので、コードに手が付けられないレベルなら次回からは他を当たったほうが良いかも知れませんよー。幸いExcel／VBAなら優しい掲示板が多いので。

Comments

[bonbaye]

大変ありがとうございます。想定通りの挙動になりました。
正直諦めて、手入力で1つづつ色文字を抜き出して進めていたところだったので、まさか回答例をいただけるとは思わず、驚いています。

＞一応teratailはエンジニア向けのサービスらしいので、コードに手が付けられないレベルなら次回からは他を当たったほうが良いかも知れませんよー。
こちらはその通りかと思いますので、teratailでの質問は今後止めておこうと思います。

この度はありがとうございました。