[[20170124124035]]　『青文字の抽出について』（けい）　ページの最後に飛ぶ

『青文字の抽出について』（けい）

エクセルのフォントで青文字だけを別シートにvbaで抽出したいのですが、
方法が分かりましたら教えて頂けますでしょうか？

具体的には
シート1のA列から、M列の範囲でセルのフォントが青文字だけを別シートに
抽出したいです。
列は変わりませんが最終行は大体1000行ですが月によって変動あります。
セル内で一部青文字というのはなく、同じセルなら全部青です。

フィルターで、aから順番に色フィルターすればいいのかもしれませんが、
量が多いのでvbaで出来ればと思い投稿しました。

よろしくお願いしますΣ（ﾟдﾟlll）

＜使用 Excel：Excel2013、使用 OS：Windows7 ＞

別シートのどこに抽出するのか分かりませんが、同じセルにそのまま抽出の例です
シート2に抽出してます。

Sub fontcolor()
Dim End_row As Long
Dim i As Long
Dim c As Long
Dim j As Long

    End_row = Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row

    For i = 1 To End_row
    For j = 1 To 8
        c = Cells(i, j).Font.ColorIndex
        If c = 5 Then
            Worksheets(2).Cells(i, j) = Cells(i, j)
            Worksheets(2).Cells(i, j).Font.ColorIndex = c　'ここで文字色指定してます
        c = c + 1
        End If
    Next
    Next

End Sub

使用されている文字色が　RGB(0,0,255)　ならこれで判別できるはずです。
他の色だと判別できません。

ご参考まで。
（pooh） 2017/01/24(火) 13:34

 poohさんのパクリです。すいません。こんな感じですね
 最終行は、Sheet1のA列だけで判断しています。
 A列よりも行の多い列は、ないですよね？？
 A～M列までなら、「For j = 1 To 13 '列」ですかね

 Sub fontcolor2()
 Dim r, i, c, j
 r = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
 For i = 1 To r '行
     For j = 1 To 13 '列
         If Cells(i, j).Font.Color = RGB(0, 0, 255) Then
            Sheets("Sheet2").Cells(i, j) = Sheets("Sheet1").Cells(i, j)
            Sheets("Sheet2").Cells(i, j).Font.Color = RGB(0, 0, 255)
         End If
    Next
 Next
 End Sub
 ------------------------------------------

 青文字をRGBで表すと、何ですか？
 例えば、RGB(0,102,255)
         RGB(0,0,255)
 どちらも青文字です。

 青文字がある単一セルが選択された状態で、
 右クリックをして、
 メニューの中の「セルの書式設定」
 →「フォント」tab
 →色をプルダウンして、「その他の色」
 →ユーザー設定にて
 →赤、緑、青の値を教えてください。
 ----------------------------------------

H列だと何故か思い込んでいました！すみません！
おっしゃる通り、M列だと「For j = 1 To 13」ですね。
失礼致しました！

（pooh） 2017/01/24(火) 14:19

どういう出力を望んでいますか？ A列に並べる？それとも元と同じセルアドレスにする？
とりあえず、検索機能を使う例なぞ。出力は、A列に並べてみてます。

 Sub test()
    Dim wk1 As Worksheet
    Dim wk2 As Worksheet
    Dim R As Range
    Dim cSt As String
    Dim iR As Long

    Set wk1 = Sheets("Sheet1")
    Set wk2 = Sheets("Sheet2")
    wk2.Cells.ClearContents

    With Application.FindFormat
        .Clear
        .Font.Color = RGB(0, 112, 192)
    End With
    Set R = wk1.Cells.Find(What:="*", SearchFormat:=True)
    If Not R Is Nothing Then
        While cSt <> R.Address
            If cSt = "" Then
                cSt = R.Address
            End If
            iR = iR + 1
            wk2.Cells(iR, "A").Value = R.Value
            Set R = wk1.Cells.Find(What:="*", SearchFormat:=True, After:=R)
        Wend
    End If
 End Sub
（???） 2017/01/24(火) 14:34

すみません、いま席を外してるので、青文字のrgbは後ほどご連絡しますΣ（ﾟдﾟlll）

皆様のマクロも試してみますので、もう少々お待ちください(＞人＜;)

出力ですが、出来れば新しいシート（シート2）のA列に並べたいです。
もし元と同じセルに出力するなら、セルがとびとびになるので、
その場合は空白セルを消したいです。。。
ごめんなさい、ややこしくて、、、
（けい） 2017/01/24(火) 14:36

 すみませんが回答ではありません。2番目の回答者はなぜコメント欄から書いていないのでしょうか？
（bi） 2017/01/24(火) 14:37

青文字のＲＧＢですが
赤0、緑112、青192でした
（けい） 2017/01/24(火) 14:41

 皆さん指摘の通り　青　といっても、いろんな青があります。
 処理方式としては ??? さんの　書式検索　が一番効率がいいと思いますが、
 各セルをチェックしていく方式の一例です。

 該当のセルはとりあえずメッセージで表示しています。
 ★のところは、実際の値に直してください。

 Sub Sample()
    Dim c As Range
    Dim r As Range
    Dim fColor As Long

    fColor = RGB(0, 112, 192)       '★

    For Each c In Columns("A:L").SpecialCells(xlCellTypeConstants)
        If c.Font.Color = fColor Then
            If r Is Nothing Then
                Set r = c
            Else
                Set r = Union(r, c)
            End If
        End If
    Next

    If r Is Nothing Then
        MsgBox "指定の文字色のセルはありません"
    Else
        MsgBox "以下のセルです" & vbLf & r.Address(False, False)
    End If

 End Sub

（β） 2017/01/24(火) 14:49

 既にエキスパートの方から回答あるし、いい方法ではなさそうだけど

 Sub test()

     Dim r As Range
     Dim a As Long

     a = 1
     For Each r In Sheets("Sheet1").UsedRange
         If r.Font.Color = RGB(0, 112, 192) Then
            Sheets("Sheet2").Cells(a, 1).Value = r.Value
            a = a + 1
         End If
     Next

 End Sub
（bi） 2017/01/24(火) 14:59

みなさま、どうもありがとうございます。
???さまのＶＢＡで思った通りの表になりました！

アドバイス頂いたみなさま、どうもありがとうございます！
大変助かりました！

（けい） 2017/01/24(火) 16:59

コメント返信：

[ 一覧(最新更新順) ]

[[20170124124035]] 『青文字の抽出について』（けい） ページの最後に飛ぶ

[[20170124124035]]　『青文字の抽出について』（けい）　ページの最後に飛ぶ