[[20161019140551]] 『背景色をコピーしたい』(ふみ) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『背景色をコピーしたい』(ふみ)

こんにちは。
ひとつのブックにSheet1とデータベースという2つのシートがあります。

xlBook.Worksheets("Sheet1").Range("E" & I).Value = Application.VLookup(xlBook.Worksheets("Sheet1").Range("A" & I).Value, xlBook.Worksheets("データベース").Range("B3:D1048576"), 3, False)

という様に、Sheet1のA列と同じ値をデータベースのB列から探して、
Sheet1のE列、F列、G列、H列にデータベースのD列、F列、E列、C列の値を
入力するところまでは出来ました。

データベースのG列はその値によって3色の背景色を塗る様にしていますが、
その同じ色をSheet1のE列に塗りたいのですが、うまくいきません。
単純にValueをInterior.ColorIndexに置き換えたりしてみましたがダメでした。どの様にコードを書いたら良いのでしょうか。よろしくお願いします。

< 使用 Excel:Excel2007、使用 OS:Windows7 >


考え方だけですが、
・Match関数を利用して、一致するセルの行番号を得ます。
・その行のG列のInterior.ColorIndexを転記先のセルのInterior.ColorIndexにセットします。
書式のみコピーペイストしてもよいかもしれません。(背景色以外もコピーされますが)
(γ) 2016/10/19(水) 14:44

 かぶりましたが。

 VBA処理であれば(全体が見えませんがおそらく)VLOOKUPでの値取得は、あまり感心しない方式だと思います。
 少なくとも、今回のデータ、取得したそのセルを参照しなければいけない場合、VLOOKUPでは、そのセルがどこであったかが
 わからないですね。

 Application.MATCH ないしは Findメソッドを使って、該当セルを取得、そのセルの行の D,F,E,C列の値を
 SHeet1の E,F,G,H列に転記するとともに、そのセルの行のG列の背景色をSheet1のE列の背景色にするといった
 制御になりますね。

 で、背景色ですけど、もし「本当の背景色」なら セル.Interior.Color を使って取得できますし
 条件付き書式による塗りつぶしであれば セル.DisplayFormat.Interior.Color で取得できます。
 (本物の背景色もセル.DisplayFormat.Interior.Colorで取得できますので、無条件に セル.DisplayFormat.Interior.Color を使ってもいいです)

(β) 2016/10/19(水) 14:53


 DisplayFormatプロパティ(およびオブジェクト)は2010で追加された物では?
(ねむねむ) 2016/10/19(水) 15:04

 >>DisplayFormatプロパティ(およびオブジェクト)は2010で追加された物では?

 わぁ!! 質問者さんのバージョンを確認していませんでした。

 To ふみさん

 ということで、条件付き書式の塗りつぶしの場合、xl2007では、直接、その色の取得ができません。
 (できますけど、そのために膨大なコードを書く必要が出てきます)

 ですから、条件付書式で判定している条件をコード内であらためて判定して、そこにどんな色が塗られている「はずだ」ということで
 転記先に背景色をセットしなければいけませんね。

 あるいは、その条件がどんなものなのかが見えませんが、Sheet1のE列にもデータベースのG列に設定している条件付書式とおなじものをセットすれば
 うまくいくかもしれませんね。

(β) 2016/10/19(水) 15:10


皆さん、ありがとう御座います。

とりあえずVLookupをやめて、Matchにして、Sheet1のJ列にデータベースのどの行かを書き出す為に、

xlBook.Worksheets("Sheet1").Range("J" & I).Value = Application.Match(xlBook.Worksheets("Sheet1").Range("A" & I).Value, xlBook.Worksheets("データベース").Range("B3:B1048576"), 0)

で成功しました。

しかし、この行番号を使って、どの様なコードを書いたら良いかnet上を探し回っておりますが
見つかりません。

現時点の御報告です。
(ふみ) 2016/10/19(水) 15:24


 転記元と転記先を逆にしていましたので、Sample の当該部分を置き換えました。(10:13)

 以下は参考コードです。

 "Sheet1" と "データベース" という名前のシートを持つ新規ブックを用意し、そこに以下のコードを貼り付けてください。

 まず、DataGen を実行してください。テスト用のデータを作成します。
 で、Sample を実行してください。
 なお、データベースシートのG列の背景色は、実際に塗りつぶされた色ということにしています。
 条件付き書式でセットされた色であれば、コメントしたように、これでは色の取得は不可能です。

 SHeet1側処理が、どこからどこまでなのかが不明でしたので、以下では 1行目からデータ最終行までとしています。

 なお、現在の構え、関数によるマッチングをふまえて、MATCH検索コードにしていますし、転記コードもわかりやすいように
 セル毎にしていますが、処理効率としては、あまり感心しない方式です。
 これを転記の4つのセルに1行、1回で書きこむこともできますし、あるいは配列に入れておいて
 どさっと全体を1回で結果を書きこむこともできます。
 また、全く異なるマッチングコードで書くこともできます。

 Sub TestGen()
    Dim I As Long
    Dim n As Long
    Dim x As Long

    With Sheets("Sheet1")
        .Cells.Clear
        For I = 1 To 100
            n = Int(150 * Rnd + 1)
            .Cells(I, "A").Value = "Data" & n
        Next
    End With

    With Sheets("データベース")
        .Cells.Clear
        For I = 3 To 200
            n = Int(150 * Rnd + 1)
            .Cells(I, "B").Value = "Data" & n
            .Cells(I, "C").Value = "C" & n
            .Cells(I, "D").Value = "D" & n
            .Cells(I, "E").Value = "E" & n
            .Cells(I, "F").Value = "F" & n
            .Cells(I, "G").Value = "G" & n
            n = Int(4 * Rnd + 1)
            x = 0
            Select Case n
                Case 1
                    x = vbRed
                Case 2
                    x = vbYellow
                Case 3
                    x = vbCyan
            End Select
            If x > 0 Then .Cells(I, "G").Interior.Color = x
        Next
    End With

 End Sub

 Sub Sample()
    Dim xlBook As Workbook
    Dim sh1 As Worksheet
    Dim shD As Worksheet
    Dim I As Long
    Dim r As Range
    Dim z As Variant
    Dim x As Long

    Set xlBook = ThisWorkbook
    Set sh1 = xlBook.Sheets("Sheet1")
    Set shD = xlBook.Sheets("データベース")

    Set r = shD.Range("B3", shD.Range("B" & Rows.Count).End(xlUp))  '検索領域

    For I = 1 To sh1.Range("A" & Rows.Count).End(xlUp).Row      'Sheet1 の 1行目からデータ最終行まで繰り返し

        z = Application.Match(sh1.Range("A" & I).Value, r, 0)
        If IsNumeric(z) Then    'マッチした場合のみ
            x = r.Row + z - 1   'そのデータベースシート上の行番号
            sh1.Range("E" & I).Value = shD.Range("D" & x).Value
            sh1.Range("F" & I).Value = shD.Range("F" & x).Value
            sh1.Range("G" & I).Value = shD.Range("E" & x).Value
            sh1.Range("H" & I).Value = shD.Range("C" & x).Value
            If shD.Range("G" & x).Interior.ColorIndex <> xlNone Then sh1.Range("E" & I).Interior.Color = shD.Range("G" & x).Interior.Color
        End If

    Next

 End Sub

(β) 2016/10/20(木) 08:59


βさん、ありがとう御座います。

私の方でもダサダサではありますが、一生懸命コードを書いて、
とりあえず使えそうになってきています。
背景色は少し仕様を変えて、Sheet1のK列にコピーする様にしました。
その他全角とか半角とかスペース削除とか色々やっていますが、
βさんへの感謝の気持ちでコードを載せます。
本当にありがとう御座いました。

Sub 検索()
Application.ScreenUpdating = False

  Dim I As Long
  Dim J As Long
  Dim xlBook
  Set xlBook = ThisWorkbook
  Dim rg As Long

   xlBook.Worksheets("Sheet1").Columns("A:B").Select    'シート1のA列とB列の表示形式を「文字列」にする

   Selection.NumberFormatLocal = "@"

    xlBook.Worksheets("データベース").Select

   xlBook.Worksheets("データベース").Columns("B:C").Select    'データベースのB列とC列の表示形式を「文字列」にする

   Selection.NumberFormatLocal = "@"

  J = 3

  Do While xlBook.Worksheets("データベース").Range("B" & J).Value <> ""    'データベースのB列の型式セルが空白になるまでLoopを繰り返す

     xlBook.Worksheets("データベース").Range("B" & J) = StrConv(xlBook.Worksheets("データベース").Range("B" & J), vbNarrow)  'データベースのB列を半角にする

     xlBook.Worksheets("データベース").Range("B" & J) = LTrim(xlBook.Worksheets("データベース").Range("B" & J))  'データベースのB列のセルの先頭のスペースを削除する

     xlBook.Worksheets("データベース").Range("C" & J) = StrConv(xlBook.Worksheets("データベース").Range("C" & J), vbWide)    'データベースのC列を全角にする

     xlBook.Worksheets("データベース").Range("C" & J) = LTrim(xlBook.Worksheets("データベース").Range("C" & J))  'データベースのC列のセルの先頭のスペースを削除する

           If DateDiff("d", xlBook.Worksheets("データベース").Range("G" & J), Date) < 180 Then               'データベースの登録日が180日以内なら青色に塗る

                   xlBook.Worksheets("データベース").Range("G" & J).Interior.ColorIndex = 33

                      ElseIf DateDiff("d", xlBook.Worksheets("データベース").Range("G" & J), Date) < 365 Then  'データベースの登録日が365日以内なら黄色に塗る

                      xlBook.Worksheets("データベース").Range("G" & J).Interior.ColorIndex = 6

                   Else                                                                                        'データベースの登録日がそれ以外なら赤色に塗る

                   xlBook.Worksheets("データベース").Range("G" & J).Interior.ColorIndex = 3

             End If

    J = J + 1

  Loop

  I = 3

  Do While xlBook.Worksheets("Sheet1").Range("A" & I).Value <> ""    'Sheet1のA列の型式セルが空白になるまでLoopを繰り返す

      xlBook.Worksheets("Sheet1").Range("J" & I).Value = Application.Match(xlBook.Worksheets("Sheet1").Range("A" & I).Value, xlBook.Worksheets("データベース").Range("B3:B1048576"), 0)

           If IsError(Range("J" & I)) Then Range("J" & I).Value = ""

           rg = xlBook.Worksheets("Sheet1").Range("J" & I).Value + 2

           If rg = 2 Then GoTo 1

           xlBook.Worksheets("データベース").Select

           xlBook.Worksheets("データベース").Cells(rg, 7).Select

           Selection.Copy

           xlBook.Worksheets("Sheet1").Select

           xlBook.Worksheets("Sheet1").Range("K" & I).Select

            ActiveSheet.Paste

            Application.CutCopyMode = False

1

           xlBook.Worksheets("Sheet1").Range("E" & I).Value = xlBook.Worksheets("データベース").Cells(rg, 4)

           If rg = 2 Then xlBook.Worksheets("Sheet1").Range("E" & I).Value = ""

           xlBook.Worksheets("Sheet1").Range("F" & I).Value = xlBook.Worksheets("データベース").Cells(rg, 6)

           If rg = 2 Then xlBook.Worksheets("Sheet1").Range("F" & I).Value = ""

           xlBook.Worksheets("Sheet1").Range("G" & I).Value = xlBook.Worksheets("データベース").Cells(rg, 5)

           If rg = 2 Then xlBook.Worksheets("Sheet1").Range("G" & I).Value = ""

           xlBook.Worksheets("Sheet1").Range("H" & I).Value = xlBook.Worksheets("データベース").Cells(rg, 3)

           If rg = 2 Then xlBook.Worksheets("Sheet1").Range("H" & I).Value = ""

     xlBook.Worksheets("Sheet1").Range("A" & I) = StrConv(xlBook.Worksheets("Sheet1").Range("A" & I), vbNarrow)  'シート1のA列を半角にする

     xlBook.Worksheets("Sheet1").Range("A" & I) = LTrim(xlBook.Worksheets("Sheet1").Range("A" & I))  'シート1のA列のセルの先頭のスペースを削除する

     xlBook.Worksheets("Sheet1").Range("B" & I) = StrConv(xlBook.Worksheets("Sheet1").Range("B" & I), vbWide)    'シート1のB列を全角にする

     xlBook.Worksheets("Sheet1").Range("B" & I) = LTrim(xlBook.Worksheets("Sheet1").Range("B" & I))  'シート1のB列のセルの先頭のスペースを削除する

      If xlBook.Worksheets("Sheet1").Range("G" & I) > 30 Then              '納期30日以上は背景色を赤に塗る

            xlBook.Worksheets("Sheet1").Range("G" & I).Interior.ColorIndex = 3

            ElseIf xlBook.Worksheets("Sheet1").Range("G" & I) < 1 Then            '納期空白は背景色を塗らない

            xlBook.Worksheets("Sheet1").Range("G" & I).Interior.ColorIndex = 0

      End If

      If xlBook.Worksheets("Sheet1").Range("B" & I) = xlBook.Worksheets("Sheet1").Range("H" & I) Then

            xlBook.Worksheets("Sheet1").Range("I" & I) = "○"

            Else: xlBook.Worksheets("Sheet1").Range("I" & I) = "×"

         End If

     I = I + 1

  Loop

  Application.ScreenUpdating = True

  MsgBox ("検索完了")

End Sub

(ふみ) 2016/10/20(木) 10:26


 コード拝見。

 がんばって書き上げられた努力、敬服です。

 2つ、コメントしておきます。

 ・複数シートを扱う場合、どのシートを相手にしているのか、きちんと、セル領域に xlBook.Worksheets("Sheet1").Range("B" & I) のように
  シート修飾しておられるのは、大変いいことです。ぜひ、今後もこの記述方式を守っていってください。
  ただ、一部、If IsError(Range("J" & I)) Then Range("J" & I).Value = "" といったように、シート修飾がないものが
  登場しますね。このケース、アクティブシートのセルとみなされます。Sheet1 をアクティブにして実行すれば
  結果オーライですが、状況依存コードで、心もとないですね。
  ここも、きちんと シート修飾されるべきかと。

 ・そうすると、ますます xlBook.Worksheets("Sheet1").なんとか という記述が増え、コード全体が
  ごちゃつくというか、見やすいとは言えないものになりますね。
  私が Sampleでアップしたように、短めのシートオブジェクト変数を定義し、そこに、あらかじめシートオブジェクトをいれておくことで
  sh1.なんとか や shD.なんとか といったスリムな記述ができ、見やすくなると思います。
  今後のテーマとして検討してください。

(β) 2016/10/20(木) 11:04


 もう1点コメント追加しておきます。

        If IsError(Range("J" & I)) Then Range("J" & I).Value = ""

        rg = xlBook.Worksheets("Sheet1").Range("J" & I).Value + 2

        If rg = 2 Then GoTo 1

 これで、エラー時は、1 にとび(このGoTo制御も感心しないのですが)処理をスキップしていますが
 1 のところで、無条件に

        xlBook.Worksheets("Sheet1").Range("E" & I).Value = xlBook.Worksheets("データベース").Cells(rg, 4)

 データベースシートの2行目の値を転記していますね。 それでいいのでしょうか?

(β) 2016/10/20(木) 11:41


βさん、ありがとう御座います。

仰られる通りで、コードを書いていても長ったらしくてイライラしていました。
sh1.やshDに直そうと思います。

また、GoToは使わない方が良いといろんなところで目にしているのですが、
アイデアが無くてつい、使ってしまいます。

あと、コードを見直していて、1の位置を

 xlBook.Worksheets("Sheet1").Range("A" & I) = StrConv(xlBook.Worksheets("Sheet1").Range("A" & I), vbNarrow)
の前に変更して、

 If rg = 2 Then xlBook.Worksheets("Sheet1").Range("E" & I).Value = ""
の類似を4回も書いていましたが、不要になりました。
空白のセルの時、rgが2になって余計な記入をするのを防ぎたかったので、
スキップさせています。
無条件に
xlBook.Worksheets("Sheet1").Range("E" & I).Value = xlBook.Worksheets("データベース").Cells(rg, 4)
を実行してからrgが2の時だけ
If rg = 2 Then xlBook.Worksheets("Sheet1").Range("E" & I).Value = ""
で消す様にしていました。

まだデータベースの列の中で同じ値を追記した時はアラームを出したり、
日付を記入するのにカレンダー機能を使おうと思っています。
どうしてもわからなくなったらまた質問しますので、
よろしくお願いします。

ありがとう御座いました。

(ふみ) 2016/10/20(木) 14:10


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.