戻る  □一般操作のサロン  □ 使用方法  □ 新着記事  □ 新規に質問する!  □ トピック一覧  □ 検索  □ 過去ログ
[ 最新記事及び返信フォームをトピックトップへ ]
このトピック参照回数 :
指定した色

    [189503] 指定した色-

    ■親トピック/記事引用/メール受信=OFF■

    □投稿者/ ORUU -(2019/06/10(22:11))
    □U R L/
      こんにちは
      下記のコードで標準の緑色だけを抽出したいです
      
      Sub ()
          Dim i As Long
          Dim f As Boolean
          Dim myF As Range
          Dim myAdd As String
          Dim buf As Variant
          Dim myStr As Variant
          Dim WS1 As Worksheet
          Dim WS2 As Worksheet
          
          Set WS1 = Worksheets(1)
          For Each buf In Worksheets
              If buf.Name = "出力シート" Then
                  f = True
                  Set WS2 = Worksheets("出力シート")
                  WS2.Cells.ClearContents
                  Exit For
              End If
          Next
          If f = False Then
              Set WS2 = Worksheets.Add(WS1)
              WS2.Name = "出力シート"
              WS2.Cells.ClearContents
          End If
                   
              For Each buf In Worksheets
              If buf.Name <> WS2.Name Then
                  For Each myF In buf.Range("B1", buf.Range("B" & buf.Rows.Count).End(xlUp))
                      Select Case myF.Font.ColorIndex
                          Case xlColorIndexAutomatic, 1
                          Case Else
                              If IsNull(myF.Font.Color) Then
                                    If FontBlack(myF) = False Then
                                      i = i + 1
                                        myF.EntireRow.Copy WS2.Cells(i, 1)
                                        WS2.Cells(i, 3).Resize(, 2).Value = Array(buf.Name, myF.Row)
                                   
                                  End If
                              Else
                                  If Not myF.Text Like "htt*" Then
                                      i = i + 1
                                        myF.EntireRow.Copy WS2.Cells(i, 1)
                                        WS2.Cells(i, 3).Resize(, 2).Value = Array(buf.Name, myF.Row)
                                     
                                  End If
                              End If
                      End Select
                  Next
                  
              End If
          Next
        
          Set WS1 = Nothing
          Set WS2 = Nothing
          Set myF = Nothing
      
      End Sub


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [189504] Re[1]: 指定した色-

    記事引用/メール受信=OFF■

    □投稿者/ γ -(2019/06/11(07:32))
    □U R L/
      セルのすべての文字のフォントが標準の緑ということなら
      .Font.Color = vbGreen
      で判定できるのでは?
      1つでも緑の文字があるならということなら、各文字の色を判定していきます。
      
      このコードはあなたが作成したものですか?
      そうでなければ、出典を明示してください。
      そしてFontBlackというプロシージャの内容を示す必要があるでしょう。
      
      また、コード内容を説明するくらいするものです。
      説明もなしにコードを提示して、これを直せというのはどうなんでしょうか?
      




    [189525] Re[2]: 指定した色-

    記事引用/メール受信=OFF■

    □投稿者/ ORUU -(2019/06/12(22:54))
    □U R L/

      分からないから質問しています
       
      appleさんお願いします




    [189526] Re[3]: 指定した色-

    記事引用/メール受信=OFF■

    □投稿者/ γ -(2019/06/12(23:28))
    □U R L/

      私が実行したいことを明確にするよう
      確認のために質問していますが、
      そちらについてはコメント無しですか?




    [189529] Re[4]: 指定した色-

    記事引用/メール受信=OFF■

    □投稿者/ apple -(2019/06/13(09:15))
    □U R L/
      >標準の緑色
      上記は、カラーパレット下方の「標準の色」のところから「緑」を選んでつけた色
      という事なんでしょうか?
      それなら ColorIndex の値は 14 だと思います。
      
          ' 省略
          For Each myF In buf.Range("B1", buf.Range("B" & buf.Rows.Count).End(xlUp))
              Select Case myF.Font.ColorIndex ' Font の ColorIndex が
                  Case 14 ' ※色パレット下方の「標準の色」から選んだ「緑」なら
                      i = i + 1
                      myF.EntireRow.Copy ws2.Cells(i, 1)
                      ws2.Cells(i, 3).Resize(, 2).Value = Array(buf.Name, myF.Row)


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [189540] Re[5]: 指定した色-

    記事引用/メール受信=OFF■

    □投稿者/ γ -(2019/06/13(20:28))
    □U R L/
      # appleさん、ご配慮ありがとうございます。
      
      (1)ひとつのセルの中のすべての文字が緑であることを判定するなら
      すでに回答頂いたとおりです。
      
      なお、色はご自分で確認して下さい。
      ColorIndexと色の対応関係はユーザーがカスタマイズできるので、
      それができない RGBで指定する Colorプロパティを使った例を出しました。
      いずれにせよ、「緑」が実際何であるかは、そちらで確認して必要なら
      修正してください。
      
      (2)
      そのセルの中に一文字でも緑があれば 
      転記するということですか?
      
      そこが不明確です。
      質問にあたっては仕様を過不足無く提示して欲しい。
      しかも回答者がそれを確認のために尋ねているんだから、
      それに答えるのが普通だと思います。
      
      もし、(2)の仕様であれば、下記のような判定ロジックを使ってはどうでしょうか。
      
      'そのセルに一文字でも緑があれば Trueを返す
      Function FontGreen(myF As Range) As Boolean
          Dim k As Long
          For k = 1 To Len(myF.Value)
              If myF.Characters(Start:=k, Length:=1).Font.Color = vbGreen Then
                  FontGreen = True
                  Exit Function
              End If
          Next
      End Function
      色が混在していれば、IsNull(myF.Font.Color)がTrueになるので、
      そのときだけ、一文字ずつ見ることにしていると思う。
      
      あなたが提示したコードでは秘密にしているFontBlackプロシージャのなかで、
      たぶん、charactersを使っているはずです。
      最初にそれを提示しないといけない。
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [189544] Re[6]: 指定した色-

    記事引用/メール受信=OFF■

    □投稿者/ ORUU -(2019/06/13(22:41))
    □U R L/
      appleさんへ
      申し訳ありませんが何かがおかしくて動きません
       
      Sub ()
          Dim i As Long
          Dim f As Boolean
          Dim myF As Range
          Dim myAdd As String
          Dim buf As Variant
          Dim myStr As Variant
          Dim WS1 As Worksheet
          Dim WS2 As Worksheet
          
          Set WS1 = Worksheets(1)
          For Each buf In Worksheets
              If buf.Name = "出力シート" Then
                  f = True
                  Set WS2 = Worksheets("出力シート")
                  WS2.Cells.ClearContents
                  Exit For
              End If
          Next
          If f = False Then
              Set WS2 = Worksheets.Add(WS1)
              WS2.Name = "出力シート"
              WS2.Cells.ClearContents
          End If
                   
              For Each buf In Worksheets
              If buf.Name <> WS2.Name Then
                  
                  For Each myF In buf.Range("B1", buf.Range("B" & buf.Rows.Count).End(xlUp))
                    Select Case myF.Font.ColorIndex ' Font の ColorIndex が
                      Case 14 ' ※色パレット下方の「標準の色」から選んだ「緑」なら
                      i = i + 1
                      myF.EntireRow.Copy WS2.Cells(i, 1)
                      WS2.Cells(i, 3).Resize(, 2).Value = Array(buf.Name, myF.Row)
                  
                  End If
                      Else
                          If Not myF.Text Like "htt*" Then
                                      i = i + 1
                                        myF.EntireRow.Copy WS2.Cells(i, 1)
                                        WS2.Cells(i, 3).Resize(, 2).Value = Array(buf.Name, myF.Row)
                                     
                                  End If
                              End If
                      End Select
                  Next
                  
              End If
          Next
        
          Set WS1 = Nothing
          Set WS2 = Nothing
          Set myF = Nothing
      
      End Sub


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [189549] Re[7]: 指定した色-

    記事引用/メール受信=OFF■

    □投稿者/ apple -(2019/06/14(00:46))
    □U R L/
      >標準の緑色だけを抽出したいです
      なのだから、その他のケースの処理は全ていらないのでは?
      
      Sub Test()
          Dim i As Long
          Dim myF As Range
          Dim buf As Worksheet
          Dim WS1 As Worksheet
          Dim WS2 As Worksheet
          
          Set WS1 = Worksheets(1)
          On Error Resume Next
          Set WS2 = Worksheets("出力シート") ' 変数 WS2 に "出力シート" の参照取得 存在しない場合エラー
          On Error GoTo 0
          If WS2 Is Nothing Then ' 存在しない場合
              Set WS2 = Worksheets.Add(WS1)
              WS2.Name = "出力シート"
          Else
              WS2.Cells.ClearContents ' 存在した場合のみセルクリア
          End If
          For Each buf In Worksheets
              If buf.Name <> WS2.Name Then
                  For Each myF In buf.Range("B1", buf.Range("B" & buf.Rows.Count).End(xlUp))
                      Select Case myF.Font.ColorIndex ' Font の ColorIndex が
                          Case 14 ' ※色パレット下方の「標準の色」から選んだ「緑」なら
                              i = i + 1
                              myF.EntireRow.Copy WS2.Cells(i, 1)
                              WS2.Cells(i, 3).Resize(, 2).Value = Array(buf.Name, myF.Row)
                      End Select
                  Next
              End If
          Next
          Set WS1 = Nothing
          Set WS2 = Nothing
      End Sub


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [189558] Re[8]: 指定した色-

    解決!!ありがとうございました! / 記事引用/メール受信=OFF■

    □投稿者/ ORUU -(2019/06/14(22:04))
    □U R L/

      appleさんへ

      ご確認いただきありがとうございます。
      そして、お力添えをいただきありがとうございました。

      さすがNo1




    [189559] Re[9]: 指定した色-

    保留中です・・・ / 記事引用/メール受信=OFF■

    □投稿者/ ORUU -(2019/06/14(22:09))
    □U R L/

      appleさんへ

      すみません。ひとつ訂正です。

      セルに12345678910

      たった1文字 緑色だけでも抽出できますか?






    [189570] Re[10]: 指定した色-

    記事引用/メール受信=OFF■

    □投稿者/ apple -(2019/06/15(14:22))
    □U R L/
      >たった1文字 緑色だけでも抽出できますか?
      それは可能です。
      既に、γさんのレスにあるとおりです。
      セルの Font の ColorIndex プロパティ、Color プロパティは、共に
      それぞれの文字に異なる設定がされていれば、Null を返します。
      γさん提示のコードを、ColorIndex プロパティに置き換えるだけです。
      
      Sub Test_2()
          Dim i As Long, j As Long
          Dim myF As Range
          Dim buf As Worksheet
          Dim WS1 As Worksheet
          Dim WS2 As Worksheet
          
          Set WS1 = Worksheets(1)
          On Error Resume Next
          Set WS2 = Worksheets("出力シート") ' 変数 WS2 に "出力シート" の参照取得 存在しない場合エラー
          On Error GoTo 0
          If WS2 Is Nothing Then ' 存在しない場合
              Set WS2 = Worksheets.Add(WS1)
              WS2.Name = "出力シート"
          Else
              WS2.Cells.ClearContents ' 存在した場合のみセルクリア
          End If
          For Each buf In Worksheets
              If buf.Name <> WS2.Name Then
                  For Each myF In buf.Range("B1", buf.Range("B" & buf.Rows.Count).End(xlUp))
                      Select Case True ' 条件式が True なら
                      ' ※ Select Case は、先に記述した条件から調べるので、この場合順序が重要
                          Case IsNull(myF.Font.ColorIndex) ' ※各文字のFont の ColorIndex が 混在なら
                              For j = 1 To Len(myF.Value) ' 文字数だけループ
                                  ' 各文字の ColorIndex 値が 14 なら
                                  If myF.Characters(j, 1).Font.ColorIndex = 14 Then
                                      i = i + 1
                                      myF.EntireRow.Copy WS2.Cells(i, 1)
                                      WS2.Cells(i, 3).Resize(, 2).Value = Array(buf.Name, myF.Row)
                                      Exit For
                                  End If
                              Next
                          Case myF.Font.ColorIndex = 14 ' ※Font の ColorIndex が 14 なら
                              i = i + 1
                              myF.EntireRow.Copy WS2.Cells(i, 1)
                              WS2.Cells(i, 3).Resize(, 2).Value = Array(buf.Name, myF.Row)
                      End Select
                  Next
              End If
          Next
          Set WS1 = Nothing
          Set WS2 = Nothing
      End Sub


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [189575] Re[11]: 指定した色-

    解決!!ありがとうございました! / 記事引用/メール受信=OFF■

    □投稿者/ ORUU -(2019/06/15(23:02))
    □U R L/

      appleさんへ

      何度もすみませんでした。
      ありがとうございます。




    [189576] Re[12]: 指定した色-

    記事引用/メール受信=OFF■

    □投稿者/ oran -(2019/06/15(23:59))
    □U R L/

      >さすがNo1
      一歩進んだ回答が他者により先についていて、皮肉にも見えますね。




    [189577] Re[13]: 指定した色-

    記事引用/メール受信=OFF■

    □投稿者/ 与太郎 -(2019/06/16(06:56))
    □U R L/

      この質問者はおかしいね。
      チャンと回答くれているのに返事をしないで「appleさんへ」とばっかり。
      自分さえ良ければなりふり構わずといった人間で、
      端から見ていて嫌になります。

      appleさんも確か過去に、
      「私を指名して質問するのは止めてください」的なことを言っていたような。
      その割にはモクモク回答をしていて。
      不思議です。

      見ていて見苦しかったので書かせて貰いました。




    [189595] (削除)-

    記事引用/メール受信=OFF■

    □投稿者/ / -(2019/06/16(21:17))
    □U R L/

      この記事は削除されました




    [189596] (削除)-

    記事引用/メール受信=OFF■

    □投稿者/ / -(2019/06/16(21:27))
    □U R L/

      この記事は削除されました




    [189610] Re[16]: 指定した色-

    解決!!ありがとうございました! / 記事引用/メール受信=OFF■

    □投稿者/ ORUU -(2019/06/20(13:06))
    □U R L/

      皆様

      大変失礼しました。

      申し訳ありませんでした。



このトピック内容の全ページ数 / [0]

このトピックに書きこむ
Name/
E-Mail/

└>このツリーのレス記事をメールで受信しますか? YES/ NO/
Title/
URL/
Comment/ 通常モード->  図表モード-> (←の場合適当に改行を入れて下さい)
タグが使用できます。例 ⇒ <font color="blue">文字</font>
解決!!ありがとうございました! 解決       保留中です・・・ 保留        迷宮入りorほかあたって見ます・・ 迷宮入       すいませ〜ん。誰か〜! Help! ←※回答者専用
解決したらチェック       保留(コードテスト中など・・)         解決不可orレスが全く付かなくてほかのサイトに行くときなど・・
削除キー/
(半角8文字以内) 


- Child Forum -
Edit:ゆう-G