[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『背景色をコピーしたい』(ふみ)
こんにちは。
ひとつのブックに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 >
かぶりましたが。
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.