『条件付き書式で指定したセルの色を残したまま他のセルにコピー』（ココア）

お世話になります。


所属毎に氏名欄のセルに色を分けて付けて、
他のセルに色がついた状態で氏名を転記したいです。

D列に所属欄があり、E列に氏名欄があります。

条件付き書式で、D欄の所属に一致する色を
同じ列のE列氏名欄に適用していますが、
そのままコピぺすると値しかコピーできませんので、
うまくセルの色も保持してコピーできる方法はないでしょうか。

宜しくお願い致します。






＜ 使用 Excel：Excel2013、使用 OS：Windows10 ＞
----
 >うまくセルの色も保持してコピーできる方法はないでしょうか。

 クリップボードを使ってコピペしてください。
（コナミ） 2020/09/24(木) 16:27
----
VBAであればDisplayFormatを使う
（mm） 2020/09/24(木) 16:37
----
コナミ様

返信ありがとうございます。
やはりクリップボードなのですね。

手動では確認したのですが、
マクロのコピーオブジェクトで
同じ挙動は可能なのでしょうか。


宜しくお願い致します。

（ココア） 2020/09/24(木) 16:52
----
| 手動では確認したのですが、
| マクロのコピーオブジェクトで
| 同じ挙動は可能なのでしょうか。
できます。
マクロ記録を取ってみて下さい。
　
なお、参考までに条件付き書式の条件式をこちらに書いてください。
絶対参照、相対参照がポイントです。
（γ） 2020/09/24(木) 20:32
----
γ様

返信ありがとうございます。
遅くなり申し訳ありません。

条件式については以下となります。

=FIND("所属名",D1)

所属名が一致すれば、設定している色を
同じ行のE列（氏名欄）に反映しております。


宜しくお願い致します。
（ココア） 2020/09/28(月) 09:48
----
DisplayFormatを用いると1行1行判定しなければならないため、
マクロ記録で表示された
ActiveSheet.Paste （Destination）で貼り付けをしたのですが、
条件付き書式の背景色はコピーできませんでした。

一括で範囲指定してコピーできる方法はありませんでしょうか。

どなたかご存じであれば宜しくお願い致します。

（ココア） 2020/09/28(月) 16:10
----
 たまたま、他の掲示板でも似たようなトピックをやっています。
 そこで紹介されていたサイト
 　　　　　　　　　　　↓
 Office クリップボードをマクロで操作する(Office 2007以降)
http://www.ka-net.org/office/of56.html
 
 そのコードをコピぺして、
 この命令でいいんじゃないですか？
 
 PasteOfficeClipboardItem 1
 
（半平太） 2020/09/28(月) 17:02
----
＞=FIND("所属名",D1)
を
=FIND("所属名",$D1)
に変更すればよくないですか？

それでもうまくコピーできないなら、
・条件付き書式の適用範囲
・コピー元セル範囲
・コピー先セル範囲
を示してください。
できれば、マクロ記録もあればよいかもしれないですね。

（γ） 2020/09/28(月) 17:27
----
 あー、そうか。後半ちゃんと読んでなかったけど
 横のセルにも条件付き書式を適用させたいということなんですね。
 γさんの書かれているように条件式の列指定を絶対参照にして
 適用先を広げれば適用されると思いますよ。
 
 ちなみにクリップボードを使うのは色が着いたままで
 全然別の場所にコピペしたい時の話です。
（コナミ） 2020/09/29(火) 10:25
----
γ様　コナミ様

返信ありがとうございます。

$D1に変更することで背景色も一緒にコピーできたのですが、
最初に記載しておりませんでしたが、私が行いたいのは
条件付き書式を解除し、通常の背景色設定に変換したセルを
別のブックにセルの値と背景色をコピーしたいと考えておりました。

このまま別のブックにコピーしようとすると、
背景色が他の色になった状態でコピーされ不具合が起こってしまいます。

何かよい方法はありませんでしょうか。


宜しくお願い致します。

（ココア） 2020/09/29(火) 10:49
----
 あ、別場所へコピーも込みなんですね。
 となると、私ができる回答はクリップボードまでです。

 半平太さんの回答の内容はどうなんでしょうか？
（コナミ） 2020/09/29(火) 10:56
----
Wordの表にコピーペイストして、
それをまたExcelの好きなところにコピーペイストしたらよいです。

（γ） 2020/09/29(火) 11:54
----
γ様　コナミ様 

手動であれば可能なのですが、マクロの処理で
行えればと考えております。

半平太様から頂いたリンクを参照してみたのですが、
私のレベルでは理解できないものでした。。


宜しくお願い致します。
（ココア） 2020/09/29(火) 12:15
----
Wordもマクロ記録取れますよ。
ご自分でトライされたらどうですか？


（γ） 2020/09/29(火) 12:40
----
wordを経由することで背景色もコピーできましたが、
スマートでないため、条件付き書式での背景色設定を諦めて
対象の文字列に一致した場合にInterior.ColorIndexで色付けをする
アプローチを試みてみます。




（ココア） 2020/09/29(火) 14:39
----
 参考までに、条件付き書式のうち塗りつぶし色に限定して、
 これを条件付き書式によらない固定したものに変換するマクロです。
 
 コードの利用方法としては、以下のようなことが考えられます。
 (1)現在のシートのコピーシートを作成
 (2)それに対して、下記のマクロを実行（選択中のセルが対象です）
 (3)あとは、それを自由にどこにでもコピーペイストができるでしょう。
 
 Sub test()
     Dim r As Range
     On Error Resume Next
     For Each r In Selection
         With r.DisplayFormat.Interior
             r.Interior.Pattern = .Pattern
             r.Interior.PatternColorIndex = .PatternColorIndex
             r.Interior.ThemeColor = .ThemeColor
             r.Interior.TintAndShade = .TintAndShade
             r.Interior.PatternTintAndShade = .PatternTintAndShade
         End With
     Next
     Selection.FormatConditions.Delete '条件付き書式の解除
     On Error GoTo 0
 End Sub
 
 DisplayFormatが導入されたのはExcel2010からですかね。
 2007までは、結構苦労して、条件付き書式の結果の書式を取り出していたものです。
 
 今回の件は、=FIND("所属名",$D1)という単純なものですから、
 マクロで条件判定が簡単にできるので、如何様にでも細工は可能です。
 あえて上記のコードを使うこともないでしょう。
 
 まあ、閲覧者の参考に供する意味で載せておきます。

（γ） 2020/09/29(火) 20:01
----
クリップボードでもWordでもグラデーションは無理のようです。
Word経由でやってみました。
ActiveSheet.Paste （Destination）ではなく、Range.PasteSpecialです。
Wordは数回しかやったことが無いので間違っているかも知れませんし、ちょっと遅いですが、一応動いています。
Excel2016（365表示）

'要　word.objectに参照設定
 Sub Word経由()
    Dim shp As Shape
    Dim wdapp As Word.Application
    Dim wdDoc As Word.Document
    Application.ScreenUpdating = False
    With ActiveSheet
        On Error Resume Next
        Set shp = .Shapes("word")
        On Error GoTo 0
        If shp Is Nothing Then
            .Shapes.AddOLEObject("Word.Document.12", Left:=Range("O1").Left).Name = "word"
            '　　　　　　　　　　　　　　　　　↑バージョンは2013に合わせて下さい
            Set shp = .Shapes("word")
        Else
            shp.Visible = True
        End If
        Set wdapp = CreateObject("word.application")
        .Range("D2:E7").Copy
        Set wdDoc = shp.DrawingObject.Object
        With wdDoc.ActiveWindow
            .Selection.PasteAndFormat (wdFormatOriginalFormatting)
            wdDoc.Range(0, .Selection.Start - 1).Cut
        End With
        shp.Visible = False
        Workbooks(2).Sheets(1).Range("c12").PasteSpecial "HTML"
    End With
    Application.ScreenUpdating = True
 End Sub

（kazuo） 2020/09/29(火) 22:35
----
 >所属毎に氏名欄のセルに色を分けて付けて、
 これをマクロでやった方がスマートそうですけどね
（´・ω・`） 2020/09/30(水) 06:38
----
kazuoさん ありがとうございました。
埋め込みオブジェクトを使うのは思いつきませんでした。
正常動作することを確認できました。
今後の参考にさせていただきます。

（γ） 2020/09/30(水) 07:39