[[20050901235833]]　『色付きセルを抽出し同シート内に左詰めで表示』（CABIN）　ページの最後に飛ぶ

『色付きセルを抽出し同シート内に左詰めで表示』（CABIN）

[色付きセルを抽出し、同シート内に左詰めで表示したい]

   |  Ａ　　Ｂ　　Ｃ　　Ｄ　　Ｅ　 Ｆ　 Ｇ　　　　表１
－－－－－－－－－－－－－－－－－－－－－－
１ | Ａ社　 10   赤15  青20   30   45  黄50
   |
２ | Ｂ社　 20    35   緑20  茶60  80   90
   | 
３ | Ｃ社　青30   30   茶50   70   75   80
   |
４ | Ｄ社  赤10  青30   35    45  黄55 赤70
   |
５ | Ｅ社   15    20    50    60   75   90
   |
６ | Ｆ社　黄10  青15  青20　赤45 橙55 緑70

   |  Ａ　　Ｂ　　Ｃ　　Ｄ　　Ｅ　 Ｆ　 Ｇ　　　　表２
－－－－－－－－－－－－－－－－－－－－－－
１ | Ａ社　赤15  青20  黄50
   |
２ | Ｂ社　緑20  茶60  
   | 
３ | Ｃ社　青30  茶50   
   |
４ | Ｄ社  赤10  青30  黄55 赤70
   |
５ | Ｅ社  
   |
６ | Ｆ社　黄10  青15  青20　赤45 橙55 緑70

はじめまして、過去ログを見ましたがよく似たものは有りましたが、

対応するものが無く、困っています。

諸先生方のお力をお借りしたく投稿いたしました。

表１で色の付いているセルのみを抽出し、同シート内に

表２のように左詰めで表示したいのですが、可能でしょうか。

出来れば、上記、表１のＢ列～Ｇ列の列幅をゼロにしておき、

Ｈ列から表２のＢ列～Ｇ列の内容を表示したいのですが？

宜しくお願いいたします。

使用環境：WINDOWS XP EXCEL2002

 マクロの記録から作成したものです、どうでしよう？。当該シートにカーソルを置いて実行します。
 値が未記入のセルも左に詰まります。　　　　　　　　　　　　　　　　　　　　(LOOKUP)

 非表示にするもの
 Sub Macro1()
     Application.ScreenUpdating = False
     Dim R As Range
     Range("B1:G" & Range("A1").End(xlDown).Row).Copy
     Range("H1").Select
     ActiveSheet.Paste
     Application.CutCopyMode = False
     For Each R In Selection
     If R.Interior.ColorIndex = xlNone Then R.ClearContents
     Next
     Selection.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
     Columns("H:K").Hidden = False
     Columns("B:G").Hidden = True
 　　Range("H1").Select
     Application.ScreenUpdating = False
 End Sub

 全体を表示するもの
 Sub Macro9()
     Columns("B:G").Hidden = False
     Columns("H:M").Hidden = True
 　　Range("A1").Select
 End Sub

 少し面倒ですが、VBAを使わない方法で考えてみました。
 B列からG列を選択してコピー＞H列に書式の貼り付け
 セルH1を選択して、挿入＞名前＞定義で
 参照範囲に　=GET.CELL(63,Sheet1!B1)+NOW()*0　で、名前を色
 H1セルに　=IF(色,B1,NA())　として、他のセルに数式の貼り付け
 H列からM列を選択してコピー＞値の貼り付け
 H列からM列を選択して、編集＞ジャンプ＞セル選択＞定数でエラー値だけチェックでOK
 編集＞削除＞左方向を選んでOK

 （川野鮎太郎）

LOOKUPさん、川野さん、ご教授ありがとうございました。

どちらも、上手くいきました。もう一つお聞きしたいのですがVBAのほうで、

範囲を変えるには、どこを変えればいいのでしょうか？（例えばS3:Z20)

VBAを使わない方法ですが、毎回使うものなので、少々、面倒でした。(^_^;)

自動記録で上の作業をおこなえば、VBAとして使えるんでしょうか？

よろしくお願いします。(CABIN)

 LOOKUPの回答のテーマは、この部分です。着色している部分を空白にして
 後で一括して削除する意味です。個別に削除して行くほうが速いのかもしれませんが、
 セルが削除してしまうため、次々と継続する処理が、現在の私には、考え付きません。

     For Each R In Selection
     If R.Interior.ColorIndex = xlNone Then R.ClearContents
     Next
     Selection.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft

 対象範囲を変更する場合には、マクロの記録で、コピー、貼付け、列の表示、非表示を
 実行しますと、すぐわかると思います。私もそのようにして作成しています。 (LOOKUP)

コメント返信：

[ 一覧(最新更新順) ]

[[20050901235833]] 『色付きセルを抽出し同シート内に左詰めで表示』（CABIN） ページの最後に飛ぶ

[[20050901235833]]　『色付きセルを抽出し同シート内に左詰めで表示』（CABIN）　ページの最後に飛ぶ