エクセルの学校：全文検索：Hyper Estraier： kazu 条件付書式

Results of 1 - 1 of about 406 for kazu 条件付書式 (0.004 sec.)

kazu (7739), 条件付書式 (2647)

[[20031112110645]]: #score: 6690; @digest: fd489f80afbb357e43d0c293de4a20ae; @id: 4041; @mdate: 2003-11-19T10:36:20Z; @size: 29051; @type: text/plain; #keywords: onkey (23965), 弥太 (9617), target (7807), address (5484), destination (4883), application (4555), iserror (4336), enableevents (4189), ramrun (4016), 太郎 (3780), activecell (3354), colorindex (3183), 元デ (3127), エリ (3037), ジョ (3014), 付書 (2856), エラ (2854), ケン (2849), elseif (2839), copy (2816), キー (2657), 最近 (2629), 書式 (2565), ラー (2490), カン (2430), rng (2142), ョン (2131), 件付 (2052), exit (2043), バー (1803), リア (1796), コー (1696); 『ある値の時そのセルと同じ書式を適用したい』（まーちん）
入力したセルの値が、あるいくつかのセルの値のうちのひとつと同じ場合にそのセルと同じ書式を適用したい。例えばA1からI1までにデータを入力しそれぞれ文字色やセルの色、罫線などの書式を設定します。これらが元データとなります。そして他のセルにデータを入力した際、これらの中の一つと同じデータが入力された場合に自動的に同じ書式を適用したいのです。簡単に言うと、コピーアンドペーストを自動的にやりたいという事なんです。できれば入力した直後に適用されるような形が望ましいのですが、こんな事は可能でしょうか。どなたか御教授よろしくお願い致します。 条件付書式で同じようなことができるのですが、3つまでしか条件を指定できないので3つ以上の条件を指定したいので利用できません。 条件付書式はとても便利なんですが、3つしか条件が指定できないのは惜しいと思うのは私だけでしょうか? ---- 「図のリンク貼り付け」で限界突破することが出来ます。（面倒くさい、重い、遅いの三拍子そろってしまいますが）条件がA1からI1の値で九つあるとして、シートを四つ用意します Sheet1 表示用 Sheet2 入力用のシート Sheet3 入力用のシートを参照 Sheet4 〃 ●Sheet3、Sheet4の設定必要範囲にSheet2への参照式を埋め込みます。それぞれのA1セルに=Sheet2!A1として該当セル範囲へ貼り付け。（必要範囲だけにしておいたほうが良いです）また、参照式によって本来の空白セルに「0」が表示されてしまうので、「ツール」「オプション」の表示タブで「ゼロ値」のチェックをはずします。これでSheet2の内容（セルの値）がSheet3、Sheet4に反映されます。 ●条件付書式の設定 Sheet2、Sheet3、Sheet4、を作業グループにします。（シート見出しをCtrlキーを押しながら選択） Sheet2で必要範囲にA1からC1の値に対応する条件付書式を設定します。作業グループを解除し、 Sheet3の条件付書式をD1からF1の値に対応する条件付書式 Sheet4の条件付書式をG1からI1の値に対応する条件付書式 に編集します。 ●Sheet1へ図をリンク貼り付け次に表示用のSheet1へそれぞれのシートの表示を画像として反映させます。 Sheet2の使用する範囲をコピーSheet1のA1セルを選択し、 Shiftキーを押しながらメニュー「編集」→「図のリンク貼り付け」 Sheet3、Sheet4についても同様にSheet1へ「図のリンク貼り付け」を行います。入力はSheet2で行い、表示をSheet1で行うことによって 条件付書式を拡張することが出来ます。条件による書式が増えたり、データ量が多かったりするとそれだけ参照式やシートが増えてしまうので、かなり重くなること間違いなしです。そのへん注意してご検討ください。 (KAMIYA) ---- まーちんさん、こんな方法もおますわ。ただ、これにも弱点はありましてナ、コピーの元になるセルから上に書式をコピーしよとしてもあきまへんわ。ハッキリ検索範囲が指定でけたら問題おまへんけど、不特定多数やと検索方向が最上列〜右方向になってますさかいなぁ...。旨く使えばっちゅう条件付きですわ、えぇ。まぁ、試してみる価値はあると思いまんねんけどナ。ほな...（弥太郎） Alt+F11 Sheet1 選択 F7 下のコードをコピーですわ。先に書式とそのデータはそれぞれせるに入力しておいておくんなはれや。後は任意のセルに入力してくだはれ。ほな...（弥太郎） Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False For Each c In Range("a:iv") If c = Target Then c.Copy Destination:=Range(Target.Address) Exit For End If Next Application.EnableEvents = True End Sub ---- これやっぱしアカンわ。複数のセルを選択したらエラーが出よるがな。止めとこ。この案引っ込めた（弥太郎） ---- (KAMIYA)さん（弥太郎）さんどうもありがとうございます。返事遅くなってごめんなさい。早速試してみたんですけど(KAMIYA)さんの方法はせっかく丁寧にたくさん書いていただいているのですが・・・ごめんなさい、わたしが初心者なせいで理解し切れていないため実行できておりません。せっかく考えていただいたのにと思うと自分が理解できない事が情けなく思います。（弥太郎）さんの方法は書いてあるとおりにスクリプトをコピーしてみたら、どこを参照元にしていいかわからなかったのですが、勘で一番上の行かなと思い参照用の元データを並べてみたところ、できました! どうやら一番上の行だけでなくても左上から右下への順番で検索がされていて、初めて出てきたデーターと同じデーターがその後に入ると最初に出てきたデーターのセルが丸ごとそこにコピーされる仕組みですね。最初検索方向が〜というのの意味がわかりませんでしたがいじっていたらわかりました! これものすごく便利だと思います! ただ（弥太郎）さんも書いているとおり、複数のセルをコピーしてしまうとエラーになってしまうのが問題です。複数のセルをコピーするような操作はしないのならこれで完璧と思いますが、残念ながらそういう操作を結構頻繁に行わなければならないシートにこの機能を盛り込みたいので、ん〜どうしたものか・・・ところでこれは検索するエリアをあるひとつの四角いセルの集合体に設定することは可能ですか? ---- -ぼくも入れて下さい（元祖すがやん）。弥太郎氏のアイディアを使って、こういうのはいかがですか。これは、入力で自動的にかわるものではありません。したがって、シートのコードエリアではなく、標準モジュールに書いてください。標準モジュールは、VBA で、「挿入⇒標準モジュール」で出ます。弥太郎氏のコードが基本なので、そういう名前がついています。 -使い方は、はじめに、コピー元となるエリアを選択して下さい。つぎに、書式変更をするエリアを、Ctrl + ドラッグで選んでください。Ctrl を忘れずに。次に、F8 を押し、Yata2 を選んで実行キーを押して下さい。2つ目の選択領域を調べて、この中に、一つ目の選択領域のうちのどれかと同じデータがあれば、その書式を、コピーしてきます。（マクロはボタンに登録、特定のキーに登録などが可能です。）書式は、色、罫線、文字種、文字の大きさ等全部です。 -書式のコピー元として、書式の原型を書いたエリアを作っておいてもいいと思います。もしそういうことをおやりになる場合は、その書式原型エリアに名前を付けて、もう少し簡便なやり方が考えられると思います。（実はぼくは、このやり方で「条件付書式」のもう少し使いやすいバージョンをフリー公開しようかな、などと少し考えていたことがありました。）（通りすがりの者） Sub Yata2() '選択的書式コピー v0 = InStr(1, Selection.Address, ",") v1 = Left(Selection.Address, v0 - 1) v2 = Mid(Selection.Address, v0 + 1, 1000) For Each Cc In Range(v2) For Each Cc2 In Range(v1) If Cc.Value = Cc2.Value Then Cc2.Select Selection.Copy Cc.Select Selection.PasteSpecial Paste:=xlFormats End If Next Next End Sub ---- （元祖すがやん）さんありがとうございます。実行してみましたが私の使っているPCの環境では少し重たいみたいです。とても便利だと思うんですが、せっかく考えていただいたのに申し訳なく思います。このシートは私以外の方も使うものなので説明が必要だったり特殊な操作をしなければならないものではないものが望ましいです。そういう点で（弥太郎）さんのスクリプトがかなり私の理想に近いです。元データ検索範囲の指定はFor Each c In Range("a:iv")というところをいじりましたらできました。これを複数のセルを編集した際にもエラーが出ないようにすることはできないでしょうか? 複数のセルのデータを一度に削除しようとしただけでエラーになってしまったので。このままでは使えないんですが、とても便利なだけになんとか・・・わがままばかり言って申し訳ありません。本当は自分でマクロ書けばいいのでしょうが勉強する時間がなくて。興味はあるので時間があったら勉強します。 ---- ほんなら「元祖すがやん」に挑戦ですわ。このワークシートイベントは危険がつきまといますさかい、エンターキーでやってみまひょか。このマクロは完全に空欄で区切られた（コレ重要）集合体を検索してそれをコピーするように組んであります。 yata3の実行でEnterキーを（必要項目入力の上）叩けばお望みの範囲をコピーでけますわ。End_Copyを実行するまでEnterキーが有効になってますさかい、そこんとこ気ぃつけとっておくんなはれや。テンキーのEnterキーや↓キーでは反応しまへんさかい、検索文字でもそのキーを利用すればコピーはせえしまへんでぇ。あと、集合体でッけど、データが繋がってないと拾いまへんでぇ。まあ、色々試してみておくんなはれ。それから複数のセル問題もクリアしてま。ほな...（弥太郎） '標準モジュールにコピペ Sub yata3() Application.OnKey "‾", "get_copy" End Sub '--------------- Sub get_copy() Dim max_row As Long, max_col As Long Dim grp_row As Integer, grp_col As Integer max_row = ActiveSheet.UsedRange.Rows.Count max_col = ActiveSheet.UsedRange.Columns.Count For Each c In Range(Cells(1, 1), Cells(max_row, max_col)) If c = ActiveCell.Value Then Set grp = Range(c.Address).CurrentRegion grp_row = grp.Rows.Count grp_col = grp.Columns.Count grp.Copy Destination:=ActiveCell Exit For End If Next End Sub '--------------------- Sub end_copy() Application.OnKey "‾" End Sub あとひとつ、集合体のどの文字にも反応します。 ---- -挑戦されても困るんですが……。このマクロは、どこかへ何かを入力すると、上の表を調べて、表中に同じものがあれば、表全体をこぴーするのですか? 興味深い動きですね。（通りすがりの者） ---- えぇ、一応そうなっとりまんねんけど、チョッと反応しすぎかも分かりまへんわ。つまり、表のに記載してあるデータを迂闊に書くといきなり表が出現する事になりますさかい、もてあますかも知れまへんなぁ。ま、それは今晩ゆっくり考えまっさ。明日仕事やし、わしゃもう風呂入って寝るで（弥太郎） ---- （まーちん）なんかすごい機能になってますね、面白いと思います。でも（弥太郎）さんの最初のマクロの機能で、エラーさえ出なければわたしは十分なんですが・・・わたしの職場ではマクロをできる人がひとりもいなくて、一番エクセルを使える人がわたしで、それでもこんなレベルでして、標準の関数をちょこっと使える程度です。わたしはエクセルわりかし好きなんですが、職場のひとたちはコピペすらめんどくさがるような人もいて、そのために少しずつ作った表のフォーマットが崩れて行ってしまうんです。忙しいせいもあるんですがね。そこでこういう機能が欲しくなったわけです。マクロ使いこなせたらかっこいいですよねー会社ではヒーローじゃないですか? ---- 最近 ...ほなと、元気ないのかと思ったら頑張ってますね。最初のマクロでエラーがでなければいいのなら、こんなかんじでどうでっしゃろ? （おいぼぅれramrun）最近ケンさんが私を打ち滅ぼそうとしているんです（笑）。 http://ryusendo.no-ip.com/cgi-bin/daken/type.cgi Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub Application.EnableEvents = False For Each c In Cells If c = Target Then c.Copy Destination:=Range(Target.Address) Exit For End If Next Application.EnableEvents = True End Sub ---- これ、数字の 0 が打てないようなので修正。 >これやっぱしアカンわ。アカンコで済んだら警察要りません。一度出したものを引っ込めるとは、真の漢とは呼べま千円。 >ほんなら「元祖すがやん」に挑戦ですわ。下克上でっか? ワクワク。（ramrun）本日ハ晴天ナリ Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub Application.EnableEvents = False For Each c In Cells If c = Target.Text Then c.Copy Destination:=Range(Target.Address) Exit For ElseIf c.Address = Target.Address Then Exit For End If Next Application.EnableEvents = True End Sub ---- 弥太郎さん大変助かっています。ありがとうございます。なぜか私のところでは、最新のコードですと、毎回何か入力するたびにエラーになってしまいます。もしかしたら関数を使っているセルがあるためかもしれません。一つ前のコード「最近ケンさんが私を打ち滅ぼそうとしているんですバージョン」ですとエラーは毎回出ないんですが、元データの検索でヒットしないデータを入力するとエラーが出てしまいます。一番最初のバージョンでは元データ検索エリアを指定できたのですが、「最近ケンさんが私を打ち滅ぼそうとしているんですバージョン」では検索エリアの指定はできませんか? 検索エリアを指定できればヒットしないデータの入力でエラーが出るのを回避できるかと思うのですが。わたしの作りたいシートでは一番上の行に元データを並べています。（まーちん） ---- >最近ケンさんが私を打ち滅ぼそうとしているんですバージョンあんまりそれ、連呼せんといてくれますか。腹がよじれる（笑）。しかし、ちょいまち。最近ケンさんが私を打ち滅ぼそうとしているんですバージョンは、 If Target.Count > 1 Then Exit Sub を追加しただけで、そこでエラーがでているということかいな? エラーは何て? ちなみにセルが結合してあるとよろしくないけど。（ramrun）弥っちゃんは遊びに行ってます ---- おいおい、勝手に決めたらあきまへんがな、（おいぼぅれramrun）はん。危ないなぁ、チョッと仕事に精出しとったらこんな案配になりまっしゃろ〜、留守にでけへんわ、ホンマに。まーちんさん、ほんなら > わたしの作りたいシートでは一番上の行に元データを並べています。を信用して（ホントはこれを早う言うて欲しかった）最初と同程度の精度のマクロに変更しましたわ。このブックを開いた途端にOnKeyがセットされますさかいな。ワークシートのチェンジイベントと同じやと思うておくんなはれ。話は変わって、早撃ちガンマン挑戦してきましたで。1回目は要領が分からんで残り 20秒の表示で止まりましてんけど、2回目はライバルをコテンパンにやっつけましたで、えぇ。カンラ、カンラ。 '標準モジュールに Sub auto_open() yata4 End Sub '------------------- Sub yata4() Application.OnKey "‾", "get_copy" Application.OnKey "{enter}", "get_copy" Application.OnKey "{up}", "get_copy" Application.OnKey "{down}", "get_copy" Application.OnKey "{left}", "get_copy" Application.OnKey "{right}", "get_copy" End Sub '------------------- Sub end_copy() Application.OnKey "‾" Application.OnKey "{enter}" Application.OnKey "{up}" Application.OnKey "{down}" Application.OnKey "{left}" Application.OnKey "{right}" End Sub '---------------------- Sub get_copy() max_col = Cells(1, Columns.Count).End(xlToLeft).Column For i = 1 To max_col If Cells(1, i) = ActiveCell.Value Then Cells(1, i).Copy Destination:=ActiveCell Exit For End If Next i ActiveCell.Offset(1, 0).Select End Sub ---- 皆さんありがとうございます。 ramrunさんエラーは型が一致しませんというエラーです。 2 65 590 591 592 593 私の作っているファイルでは一番上の行にこのようなデーターを並べていてこれらに書式をそれぞれ設定しています。下のほうのセルに、ためしに640と入れたらこのエラーが出ました。弥太郎さんカンラ、カンラバージョン試してみましたところ、矢印キーがどれを押してもカーソルが下のセルへ移動になってしまいます。そしていくつか移動してしまいます。そして関数使っていると書きましたが、 =CHOOSE(MATCH(L44,C1:M1,0),C2,D2,E2,F2,G2,H2,I2,J2,K2,L2,M2) この関数が書いてあるセルで、しかも#N/Aになっているセルに移動するとエラーになってしまいます。この関数が入っていても#N/Aではないところはエラーになりません。今会社なんですが、今から帰りますので、次書き込めるのは夜になってしまいます。よろしくお願いします。（まーちん） ---- ほんならこれでどうでっか? 矢印キーは分かってましたんやけど、やっぱし必要でっか。 >そしていくつか移動してしまいます ???コレはなんでやろ? もう前のん捨ててこれでやってみておくんなはれ。エライ長ったらしゅうなってもたんやけど、まぁまぁ実力通りのマクロですわ、えぇ。おいぼぅれさんのに手ぇ加えた方が速いかも知れまへんけど、なんですわ、マクロは裏方の仕事ですさかい、冗長でも何でも転けんと動いて望みの結果がでたらよろしおまっしゃろ、なぁまーちんさん。ほなら...（弥太郎） '----------------- Dim keyno As Integer '----------------- Sub auto_open() get_copy End Sub '----------------- Sub end_copy() Application.OnKey "‾" Application.OnKey "{enter}" Application.OnKey "{up}" Application.OnKey "{down}" Application.OnKey "{left}" Application.OnKey "{right}" End Sub '-------------------- Sub get_copy() Dim max_col As Integer, i As Integer max_col = Cells(1, Columns.Count).End(xlToLeft).Column Application.OnKey "‾", "enter" Application.OnKey "{enter}", "enter" Application.OnKey "{up}", "up" Application.OnKey "{down}", "enter" Application.OnKey "{left}", "left" Application.OnKey "{right}", "right" For i = 1 To max_col If Not Application.IsError(Cells(1, i)) Then If Cells(1, i) = ActiveCell.Value Then Cells(1, i).Copy Destination:=ActiveCell Exit For End If End If Next i Select Case keyno Case 1 ActiveCell.Offset(-1, 0).Select Case 2 ActiveCell.Offset(0, -1).Select Case 3 ActiveCell.Offset(0, 1).Select Case Else ActiveCell.Offset(1, 0).Select End Select End Sub '------------------ Sub up() keyno = 1 get_copy End Sub '------------------ Sub left() keyno = 2 get_copy End Sub '------------------- Sub right() keyno = 3 get_copy End Sub '-------------------- Sub enter() keyno = 0 get_copy End Sub ---- きゃん、きゃん。ご主人が帰ってきた。にしても、ライバルに大差をつけましたね、さすが弥っちゃん。シートの中にエラーの数式があると確かにそうなりますね。では、最近ケンさんが私を打ち滅ぼそうとしているんですバージョン3投下。（ramrun）バレーがんがれ。 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub Application.EnableEvents = False For Each c In Cells If IsError(Target) Then Exit For ElseIf Not IsError(c) Then If c.Address = Target.Address Then Exit For ElseIf c = Target Then If Not IsEmpty(c) Then c.Copy Destination:=Range(Target.Address) Exit For End If End If End If Next Application.EnableEvents = True End Sub ↑早速ダメで置き換え。 0値と空白、エラーの数式とか考えたらゴチャゴチャになってしまいました。ちなみに結合セルはもうダメぽ。 ---- goto errorのところ書き換えてます。またマカロニコードいうていちゃもんつけられそうですさかい。もう時間がないほな（弥太郎） ---- お二方にこんなにがんばっていただいているのに、返事が遅くなってしまいまことに申し訳ないです。「実力通りのマクロですわバージョン」と「私を打ち滅ぼそうとしているんですバージョン3」両方とも試しました。ありがとうございます。「実力通りのマクロですわバージョン」は矢印キーの動きが解消されていますが関数の入っているところで#N/Aのところではエラーになります、ただしエラーになってもそのまま引き続き機能します。そこで思ったのですが、私の用意している関数で#N/Aとなってしまうところはもともと表示しない行として使う予定なので隠してみました。ところが隠している行には通常矢印キーではセルにカーソルが行かないものですが、マクロの機能でしょうか?カーソルが行ってしまうためにエラーになってしまいます。「私を打ち滅ぼそうとしているんですバージョン3」はエラーは今のところ出ませんが、なぜかデリートキーでデータ削除をすると0が入力されてしまいます。そのほかに、たまにデリートでほかのセルに入っているデータを拾ってきたりもします。しかし癖がありますが、なんとか0を表示しないオプションと、たまに拾ってくる現象がおきないようにセル配置を調整することでやりたいことができるようになりました。本当にありがとうございます。ついに実現しましたが引き続きデバッグしますので、また何かありましたらお願いしたいです。よろしくおねがいします。弥太郎さんの次のマカロニバージョンも見たいですし。 ---- 検証不足でしたね。失礼コキました。もう0非表示オプションとセル配置のやりくりは必要ありません。弥っちゃんの娘さん、速いぽ。（ramrun）私を打ち滅ぼそうとしているんですバージョン4 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub Application.EnableEvents = False For Each c In Cells If IsError(Target) Then Exit For ElseIf Not IsError(c) Then If c.Address = Target.Address Then Exit For ElseIf c = Target Then If Not IsEmpty(c) And Not IsEmpty(Target) Then c.Copy Destination:=Range(Target.Address) Exit For End If End If End If Next Application.EnableEvents = True End Sub ---- >弥っちゃんの娘さん、速いぽ。まだ扶養家族のくせしてからに、ナマイキなんやあいつ。それより、あとから!のハチマキ巻いたんがとんでもない得点挙げて行っきょりましたなぁ。なんぼ努力してもあそこまではちょっと...。え〜い、シャクに障る。どんじりに落ちん頼みの綱はケンさん一人。頼りにしてま。まーちんさん、真打ちのワタシは明日でよろしいかな? 明日1日退屈せんでもええと思うたら、ワクワクしますわ。今日はくたびれたからもう寝ます。ほな...（早寝早起き弥太郎） ---- 私も参加させてください。他の方とメインの考え方は同じですが書式を個別にコピーする方法です。ピントがずれていたらごめんなさい。（kazu） Option Explicit Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim sht As String, c As Long, c1 As Long, c2 As Long, r As Long sht = "sheet1" c1 = 1 c2 = 9 r = 1 If Target.Rows.Count > 1 Or Target.Columns.Count > 1 Then Exit Sub End If For c = c1 To c2 If Sheets(sht).Cells(r, c).Value = Range(Target.Address).Value Then Range(Target.Address).Font.FontStyle = _ Cells(r, c).Font.FontStyle ' 太字 Range(Target.Address).Font.ColorIndex = _ Cells(r, c).Font.ColorIndex ' 文字色 Exit For End If Next c End Sub ---- 弥太郎さん真打がやはりあるのですね。楽しみにしています。 kazuさんご参加ありがとうございます。ごめんなさい、わたしは初心者なのでコードだけでは使い方がわかりません。これは標準モジュールに追加でいいのでしょうか? あと元データはどこにおけばいいでしょうか? ---- まーちんさん、おはようございます。早速新規コードを下に掲載致します。えっ、どっかで見たコードですって? ほんなこと気ぃにせんとっておくれやす。正直言いましてmr.ramrunのコードをケンショウしとったら、アホらしゅうて自分のコードいじる気ぃが起こってきまへんねん。で、まぁ、元データが1行目にあるっちゅうことですさかい、検索範囲を狭めて1行目以外の表示形式を拾わんように作り替えときましたんやけど、どうでっしゃろか。それと、エラーの出とるセルを非表示にするお話、 =IF(ISERROR(CHOOSE(MATCH(L44,C1:M1,0),C2,D2,E2,F2,G2,H2,I2,J2,K2,L2,M2)),"",CHOOSE(MATCH(L44,C1:M1,0),C2,D2,E2,F2,G2,H2,I2,J2,K2,L2,M2)) ってな案配に空白セルで表示したらどうでっか? いいえぇな、マクロを使う場合、やたら結合セルとか、非表示とか、列削除とかは、避けた方が賢明ですわ。それを承知で組めたら問題おまへんけど...ナ。 >真打がやはりあるのですね寄席を観に行ったら、前座でエライ盛り上がってもて、真打の落語はおもろい事もな〜ともないっちゅう現象がしばしば起こりまんなぁ。今回はその典型的な例でして、この度は前座の腕前の物スゴさをまざまざと見せつけられましたわ、えぇ。まぁ、そのうち真打も前座に太刀打ちでける程の腕前にならんと淡い期待をよせてまんねんけどナ。（ムリムリ）おもろい事も何ともない（真打弥太郎） '------------------- '私を打ち滅ぼそうとしているんですバージョン5 Private Sub Worksheet_Change(ByVal Target As Range) Dim max_col As Integer If Target.Count > 1 Then Exit Sub Application.EnableEvents = False max_col = Cells(1, Columns.Count).End(xlToLeft).Column For Each c In Range(Cells(1, 1), Cells(1, max_col)) If IsError(Target) Then Exit For ElseIf Not IsError(c) Then If c.Address = Target.Address Then Exit For ElseIf c = Target Then If Not IsEmpty(c) And Not IsEmpty(Target) Then c.Copy Destination:=Range(Target.Address) Exit For End If End If End If Next Application.EnableEvents = True End Sub ---- [kazu]です、すみません。説明不足でした。 [Alt]キーを押したまま[F11]キーを押して、VBEの世界に入ります。もし[F11]キーがなければ、 [ツール(T)]メニュー→[マクロ(M)]→[Visal BasicEditor]で VBEの世界へ。左側にプロジェクトVBAProjectと書かれたコーナーがあります。なければ [表示(V)]メニュー→[プロジェクトエクスプローラ(P)]を選択します。プロジェクトエクスプローラの中に[ThisWorkBook]というアイコンが見えるはずです。それをダブルクリックすると、右側にThisWorkbook(コード)が表示されます。そこにVBAコードを貼り付けてください。うまく貼り付けできたら、右上の×（閉じる）でVBEの世界からぬけます。ワークシート側の元データはSheet1のA1からH1です。（kazu） ---- kazuさんのコードを改造してみました。参照元に書式を設定していないセルを残しておけば、Delキーで書式も消えるので使い勝手がかなりいいように思います。参照元も変更しやすいようにしました。 "Sheet1"とか"A1:I1"を変更すればいいです。対応する書式はコード内のコメントのとおり。ブック内の全シートに反映します。（ramrun）パクってばかりですみませんヴァージョン1 Option Explicit Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim Rng As Object, Bas As Object Set Bas = Worksheets("Sheet1").Range("A1:I1") ' 参照元 If Target.Count > 1 Then Exit Sub For Each Rng In Bas If Rng.Value = Target.Value Then Target.NumberFormat = Rng.NumberFormat ' 数値表示形式 Target.Interior.ColorIndex = Rng.Interior.ColorIndex ' セルの色 Target.Font.ColorIndex = Rng.Font.ColorIndex ' 文字の色 Target.HorizontalAlignment = Rng.HorizontalAlignment ' 文字の横位置 Target.VerticalAlignment = Rng.VerticalAlignment ' 文字の縦位置 Exit For End If Next Rng End Sub ---- みなさまお返事が遅くなって申し訳ありません。今週月曜休みで会社以外でインターネットできることが少ないのですみません。 kazuさんの試しましたところ、実行時エラー '9': インデックスが有効範囲にありませんと出ます。 ramrunさんのパクってばかりですみませんヴァージョン1 も同じエラーが出ます。弥太郎さんの「私を打ち滅ぼそうとしているんですバージョン5」すごいです、エラー完全に出ません。それに =IF(ISERROR(CHOOSE(MATCH(L44,C1:M1,0),C2,D2,E2,F2,G2,H2,I2,J2,K2,L2,M2)),"",CHOOSE(MATCH(L44,C1:M1,0),C2,D2,E2,F2,G2,H2,I2,J2,K2,L2,M2)) これすごくためになりました。隠し行を使っていたのは#N/Aを見えなくするためにやっていたのですがそのために =IF(ISERROR(L39),"",L39) こういう式を使ったりしていました。ほかに普通のデータが入っている行で隠したいところがあるので隠し行は使わなければなりません。しかし、そういえばまだ言ってなかったのですが、結合セルは使っていません。すみません、言うのがもっと早かったほうがよかったです。みなさま本当にありがとうございました。やりたかったことが完全に再現できています。また何かあったらお願いしてもいいですか? ---- まーちんさん、他のお二人の名誉のためにも申し上げておきますが、まーちんさんがもうエラー処理のコードがご自分で記入でけるもんやと踏んでのコードですわ。ほれに、アレは私のコードやおまへんねんで、えぇ。賞賛のお言葉は、前座を務めた御方にお願いしま。下のコードは原作kazu 脚色ramrun パクり屋弥太郎のコードです。kazuさんのコードにエラー処理と関数のコピーを単に付け加えただけの物です。また、暇があったら廻してみておくんなはれ。旨い事いったら、今度はいま一人の前座に拍手を贈っとっておくんなはれ。 >また何かあったらお願いしてもいいですか? いつでもどうぞほな...（パクり屋弥太郎） '--------------- Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim n As Integer Dim Rng As Object, Bas As Object n = Cells(1, 256).End(xlToLeft).Column Set Bas = Range(Cells(1, 1), Cells(1, n)) If Target.Count > 1 Then Exit Sub For Each Rng In Bas If IsError(Target) Then Exit For ElseIf Not IsError(Rng) Then If Rng.Address = Target.Address Then Exit For ElseIf Rng = Target Then If Left(Rng.Formula, 1) = "=" Then Range(Rng.Address).Copy Destination:=Range(Target.Address) ' Range(Target.Address) = Rng.Formula '拾った式を$立てで書き込む End If Target.NumberFormat = Rng.NumberFormat ' 数値表示形式 Target.Interior.ColorIndex = Rng.Interior.ColorIndex ' セルの色 Target.Font.ColorIndex = Rng.Font.ColorIndex ' 文字の色 Target.HorizontalAlignment = Rng.HorizontalAlignment ' 文字の横位置 Target.VerticalAlignment = Rng.VerticalAlignment ' 文字の縦位置 Target.Font.FontStyle = Rng.Font.FontStyle ' 文字の太さ Exit For End If End If Next Rng End Sub ---- 皆様、最後のコードを試して見ましたところこれも完璧に動いています。皆さんのコードを足して作られているわけですから、せっかくですからこちらをつかわさせていただこうと思います。皆様本当にありがとうございました。それで完成したばかりなんですが、新しいコードをお願いしたいものができてしまったのです。新しいスレッド立てますので、ぜひお時間がありましたら覗いてやってみてください。 ...; http://www.excel.studio-kazu.jp/wiki/kazuwiki/200311/20031112110645.txt - [detail] - similar

PREV NEXT

訪問者：カウンタ