エクセル 選択候補に属性を付け、優先的に表示させたいのですが

質問

お世話になります。エクセル２００２を利用しています。
シートを複数利用し、会員が施設を利用する際の利用券を発行しようとしています。
シート「名簿」にはその３行目以降に会員情報（約４００人今後増員します）があり、Ｆ列にカナ氏名・ＧＨＩ列に住所・Ｊ列に氏名・Ｋ列に年齢・Ｌ列に性別が入っています。
シート「施設」にはその５行目以降に施設名（約３００施設今後増加します）があり、Ａ列にカナ名・Ｂ列に漢字名が入っています。

ＶＢＡにより、シート「会員」の該当者の「行」を右クリックすると個人情報がシート「印刷」の指定位置とシート「施設」のセルＣ２にコピーされ、シート「施設」にシートチェンジするようになっています。
シート「施設」から利用施設を選択し、右クリックすると施設名がシート「印刷」の指定位置にコピーされ、シート「印刷」が印刷され、シート「管理簿」に発行日（印刷日）と利用施設と利用者が上の行から順にコピーされるようになっています。

お伺いしたいのは、
１．利用者を選択したら、シート「施設」の５行目以降に表示される施設情報が、過去に利用したものを優先的に上の行に表示し、そうでないものはそれらの下の行にする。
　考えたのは、施設名を選ぶと同シートのセルＣ２に表示されている利用者氏名をその施設名のＤ列から順に右へコピーしていき、その施設の属性とすることです。(参考書の.End(xlToLeft).Offset(1).Valueとかを使うのかと思いましたが、わかりません）さらに、同人物が同じ行にコピーされた場合は、コピーしないといいのです。
２．シート「施設」が開かれるときに、利用者が選択されているＣ３の情報から、該当者が記録されている行を上に表示させるようにしたいのです。　それが「並べ替え」や「コピー」でするべきなのかはわかりません。

文字数オーバーで詳しく説明できません。よろしくお願いいたします。

回答No.11

onlyrom · ベストアンサー

こんばんは。
返事が遅くなり申し訳ありません。

＞Set FindCell = Rows(R).Find(what:=Range("F2").Value,
＞この一行だけがマーカーされます。

こちらではサクサクといくんですがねぇ。(^^;;;
エラーの原因を考えてみたんですが直ぐには思い浮かびませんので別な方法を使ってみましょう。
エラーの出るFindメソッドの代わりに、CountIfを使います。

シート「施設」のWorksheet_Activateイベントプロシージャーを下記のものとごっそり入れ替えてください。
変更部分は、●に囲まれた部分です。

'----------------------------------------------------------------------
'　　施設シートがアクティブになった時の処理
'

Private Sub Worksheet_Activate()
Dim myRange As Range
Dim FindCell As Range
Dim LastRow As Long
Dim LastClm As Integer
Dim R As Long

If Range("F2").Value = "" Then Exit Sub

LastRow = Range("E65536").End(xlUp).Row

'●●●●●
For R = 5 To LastRow
Set myRange = Range(Cells(R, "F"), Cells(R, "IV").End(xlToLeft))
If WorksheetFunction.CountIf(myRange, Range("F2").Value) > 0 Then
Cells(R, "B").Value = 0
Else
Cells(R, "B").Value = 1
End If
Next R
'●●●●●

If WorksheetFunction.CountIf(Range("B5:B" & LastRow), 1) = 0 Then Exit Sub

LastClm = 5

For R = 5 To LastRow
If LastClm < Cells(R, "IV").End(xlToLeft).Column Then
LastClm = Cells(R, "IV").End(xlToLeft).Column
End If
Next R

Set myRange = Range("A5", Cells(LastRow, LastClm))

myRange.Sort Key1:=Range("B5"), Order1:=xlAscending, _
Key2:=Range("D5"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False

End Sub

'------------------------------------------------------------------------------

前回の投稿で言い忘れましたが、以前利用した施設を施設上部に表示するためのソートキーとして、「施設」のＢ列（備考１）を使っています。

テストはちゃんとしてありますので安心して試してみてください。

それにしてもなぜエラーが出たのでせう。ちょと不思議です。
まさかとは思うけれどExcelのバージョンの違いがあるのかも？？？？
因みにこちらは、Excel2000です。

ちょくちょく覗いてみますので結果をお知らせください。

以上です。

お礼

すごいです。

もう完璧です。

大変ありがとうございました。完全に作動します。
こちらは、Win2000　で　Excel2002　を使用しています。

Ｂ列（備考１）は、テキストを入力していても0か1に書き換えられるようになっていますので、列のタイトルを「ソートキー」として使用することにしました。

ここまで、懇切丁寧に教えていただき、泣けるほど嬉しいです。

いただいたコードを勉強し、せめてこの意味を他人に説明できるようにはしたいと思います。
そのときは、このサイトでonlyrom様にどれだけ親切に教えていただいたかを話したいと思います。

本当に本当にありがとうございました。大感激です。

回答No.13

onlyrom

こんにちは。

●懸案のFindメソッドのエラー、見つけました。ケアレスミスでした。(^^;;;

＞Find(what:=Range("F2").Value, LookIn:=xlValue, LookAt:=xlWhole)

この２つ目の引数、LookInの値が、
　　ｘｌＶａｌｕｅｓ　　とタイプしたはずが
　　ｘｌＶａｌｕｅ　　　　と最後のＳが抜けてました。

慣れからくるケアレスミスですね。反省、反省。
一方でxl2000ではエラーにならず、xl2002,2003ではエラーになる、というのは解せませんが、それが分かっただけで良し、としましょう。

●それから上手く動作したようで、何よりでした。。ホッ。(^o^)/~~

＞いただいたコードを勉強し、せめてこの意味を他人に説明できるようにはしたい

そうです。それがとても大事なことだと思います。
「他人に説明できて」初めて理解している、ということになるのでしょうから。

何れにしろ、これを機会にさらにＶＢＡの勉強に励んでください。
以上です。

お礼

励ましのお言葉をいただき、今後の力になります。

本当にお世話になりました。

この質問でいただいたご厚情は、一生忘れません。

ありがとうございました。

回答No.12

cafe_au_lait

なるほど、下にいましたか。

＞.Range("5:" & .Range("A65536").End(xlUp).Row) _

ここでソート範囲を指定していますので、このA65536を数式が入力されていない列(例えばE65536など)に変更すれば、空白の行はソート範囲に指定されませんので、とりあえず下に行くことは無くなります。

なお、VBAでふりがなを振るとしたら、
Target.Offset(, -1).Value = StrConv(Target.Phonetic.Text, vbNarrow)
のようになると思います。

お礼

ありがとうございました。

いろいろ教えていただきました。

関数との組み合わせでシンプルにできることがわかりました。

ただ、私の使っているパソコンが7年前のモデルなので、処理速度が遅く、関数を多くのセルに振ると、シートチェンジにもたついてしまうようです。

高性能パソコンならそんなこと無いのにとお笑いください。

最後までお付き合いくださり、ありがとうございました。

関数とのあわせ技を勉強したいと思います。

大変お世話になりました。

回答No.10

onlyrom

お待たせしました、お約束のコードです。

【最重要】
質問者がアップした「新しいレイアウト」のブックをそのまま使って試すこと。
もちろんシート上の、説明コメントの類は全て消去、してから実行ですが、

説明コメント以外は●●絶対どこも変えないように！！●●

それとシート「印刷」のセル”AL4”に利用月云々の式が入ってますがそれもセル番号が違ってきますので直すこと。
で疑問、なぜそこだけ式が？　他のセル同様VBAで代入すればいいのに、と思ったりもしますが。(^^;;;

以上のことを守って実行してもらえれば完璧に動作しますので、動作しなかった場合は再度上記のことを確認して下さい。

'■シート名簿■----------------------------------

'
'　　名簿シートの該当行右クリック処理
'

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

If Target.Row < 2 Then Exit Sub

Cancel = True

With Sheets("印刷")
.Range("E15").Value = Cells(Target.Row, "G").Value
.Range("E16").Value = Cells(Target.Row, "H").Value
.Range("E17").Value = Cells(Target.Row, "I").Value
.Range("AA16").Value = Cells(Target.Row, "J").Value
.Range("AQ16").Value = Cells(Target.Row, "K").Value
.Range("AX16").Value = Cells(Target.Row, "L").Value
End With

With Sheets("施設")
.Range("F2").Value = Cells(Target.Row, "J").Value
End With

Sheets("施設").Select

End Sub

'■シート施設■----------------------------------
'
'
'　　施設シートがアクティブになった時の処理
'
'

Private Sub Worksheet_Activate()
Dim myRange As Range
Dim FindCell As Range
Dim LastRow As Long
Dim LastClm As Integer
Dim R As Long

If Range("F2").Value = "" Then Exit Sub

LastRow = Range("E65536").End(xlUp).Row

For R = 5 To LastRow
Set FindCell = Rows(R).Find(what:=Range("F2").Value, LookIn:=xlValue, LookAt:=xlWhole)
If Not FindCell Is Nothing Then
Cells(FindCell.Row, "B").Value = 0
Else
Cells(R, "B").Value = 1
End If
Next R

If WorksheetFunction.CountIf(Range("B5:B" & LastRow), 1) = 0 Then Exit Sub

LastClm = 5

For R = 5 To LastRow
If LastClm < Cells(R, "IV").End(xlToLeft).Column Then
LastClm = Cells(R, "IV").End(xlToLeft).Column
End If
Next R

Set myRange = Range("A5", Cells(LastRow, LastClm))

myRange.Sort Key1:=Range("B5"), Order1:=xlAscending, _
Key2:=Range("D5"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False

End Sub

'
'
'　　施設シートの該当行を右クリックした時の処理
'
'

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

Dim Msg
Dim myRange As Range
Dim LastClm As Integer

If Target.Row < 4 Then Exit Sub

Cancel = True

'-----　該当施設のＦ列以降に利用者名をセット----

LastClm = Cells(Target.Row, "IV").End(xlToLeft).Column

Set myRange = Range(Cells(Target.Row, "F"), Cells(Target.Row, LastClm))

If WorksheetFunction.CountIf(myRange, Range("F2").Value) = 0 Then
Cells(Target.Row, LastClm + 1).Value = Range("F2").Value
LastClm = LastClm + 1
End If
'------------------------------------------

Sheets("印刷").Range("C10").Value = Cells(Target.Row, "E").Value & " 様"

With Sheets("管理簿").Range("A65536").End(xlUp)
.Offset(1, 0).Value = Date
.Offset(1, 1).Value = Sheets("印刷").Range("C10").Value
.Offset(1, 2).Value = Sheets("印刷").Range("AA16").Value
.Offset(1, 3).Value = "１"
.Offset(1, 4).Value = "窓口印"
.Offset(1, 5).Value = "窓口担当"
End With

'Worksheets("印刷").PrintOut

Worksheets("印刷").PrintPreview 'テスト用印刷プレビュー

End Sub

'-------------------------------------------------

先の投稿で空白行４行目を間違いに対して使うということを面白い考えだと言いましたが、それはやはり拙い方法です。何故なら施設でそれを使うと空白のまま即印刷されますし、管理簿の方には施設名など書き込こまれてしまいますので、それらを手動で消去しなければならないからです。

で、そういうことのないようにメッセージを出し確認をとっていたのですが、それがいらないということですので、▲本意ではありませんが▲「ご要望により」今回のコードには間違い等に対するチェックは入れておりません。
■よって全てが正しく処理されるとを前提■としてのコードになります。

最後に老婆心ながらの一言。
質問者のみが使うのであればそれでいいと思いますが不特定多数の人が使うのであれば、クリック回数を少なくするよりは、間違いを未然に防ぐことに重きを置く方が●非常に重要な●ことだと考えます。

以上です。

補足

事務のイロハとして、
＞間違いを未然に防ぐことに重きを置く方が●非常に重要な●ことだと考えます。

このように重要なことを教えていただき、ありがとうございました。

プレビューを表示して、印刷をするという方法まで追加していただき、ありがとうございました。　大切に使わせていただきます。

大変、あつかましいのですが、エラーメッセージが出てしまいました。申し訳ありません。対処方法を教えていただけないでしょうか。（動作確認をしていただいた上で教えていただいたのに、本当にすみません）

シート名簿の該当者のあるセル（その行のいずれかのセル）を右クリックすると、

　　　実行時エラー'9'

　　　インデックスが有効範囲にありません

と出て、デバックをクリックすると、黄色くマーカーで示される行が出ます。

'■シート施設■----------------------------------
'
'
'　　施設シートがアクティブになった時の処理
'
（中略）

For R = 5 To LastRow
Set FindCell = Rows(R).Find(what:=Range("F2").Value,

↑　この、Set FindCell = Rows(R).Find(what:=Range("F2").Value,
の一行だけがマーカーされます。

自分で意味を調べようとＶＢＡ辞典を引いたりしましたが、わかりませんでした。

私の行動は、下記のとおりです。
・「新しいレイアウト」のブックをそのまま使って試しました。
・シート上の、説明コメントの類は全て消去しました。説明コメント以外はどこも変えていないはずなのです。。（念のため、コメントのある行から最終行までを範囲指定して、クリアと削除を両方行いました）
・シート「印刷」のセル”AL4”は、とりあえずクリアしました。
・教えていただいたコードの
　　'■シート名簿■----------　
　　　　　から
　　Sheets("施設").Select
　　End Sub
　までをシート名簿のシートモジュールに貼り付けました。
・同じく、
　　'■シート施設■----------
　　　　　から
　　Worksheets("印刷").PrintPreview 'テスト用印刷プレビュー
　　End Sub
　　'-------------------------------------------------
　までを、シート施設のシートモジュールに貼り付けました。

・ThisWorkbookには何もコードはありません。
・標準モジュールにも何もコードはありません。

この様な状況になりました。
・シート施設のＦ２には、名簿で選択した会員の漢字氏名が入っています。（希望とおりです）
・ソートは行われていません。
・実行時エラーのメッセージで、［終了］をクリックしてシート施設に戻り、施設名のある行のいずれかのセルをクリックすると、印刷プレビュー画面になり、印刷項目は会員の必要項目も施設名もきちんと入っています。（希望とおりです）
・管理簿もきちんと記録されています。（希望とおりです）
・施設利用の履歴も、印刷プレビューの利用者名が、利用施設のＦ列以降にに入っています。（希望とおりです）
・同じ会員が同じ施設を利用しても、履歴は二重にはなりません。また、別の人が利用したら、利用履歴の右側空白セルに書き込まれます。（希望とおりです）

・このシートに、気づかないミスがあるのだろうと思い、新規エクセルブックに「形式を選択して貼り付け」で「値のみ」の機能を使って必要なセル範囲だけをコピーし、ＶＢＡを新規に貼り付けましたが、デバックメッセージが出て、同じ場所にマーカーが付きました。

・パソコンに問題があるのではと疑い、上記のマクロの入っていない状態のシートレイアウトを別のパソコンのエクセル2003で開き、この状態でＶＢＡを貼り付けましたが、デバックメッセージが出て、同じ場所にマーカーが付きました。

本当に本当にご迷惑ばかりおかけします。

出来の悪い質問者とお許しいただき、
マーカーの付いた行から、私が対処すべき事項を教えていただけないでしょうか。

よろしくお願いいたします。

回答No.9

onlyrom

業務連絡..(^^;;;

補足等は了解しました。
コードの変更はセル番地をちょこっと修正する程度ですが、念のため十分テストしてからアップしたいと思います。
それも暇々を見つけての作業になりますのでアップはお昼前になると思いますのでご了承ください。

以上です。

お礼

私のレベルが低いばかりに、かかりっきりでご回答をいただいているようで、本当にすみません。

私も勉強し、少しでもレベルをあげたいと思います。

ありがとうございます。

回答No.8

cafe_au_lait

追加したコードでは行を非表示にさせる操作は行っておりませんので、なぜ消えてしまったのかは分かりません。こちらではカナによるソートでも問題なく動作しています。
Workbook_SheetActivateイベントが何かしていませんか？参考URLのコードを貼り付けただけでは問題ないようですが・・・。

参考URL：

http://oshiete1.goo.ne.jp/qa2698463.html

補足

すみません。私が良く見てなかったため、勘違いしましていました。

ソートがかかっても、施設名は消えてなんかいませんでした。

実は、Ａ列はフリガナを関数で取得しようと、セルＡ5には　=ASC(PHONETIC(B5))　を入れ、それを約400行、フィルドラッグでいれていました。
ソートがかかって、見た目は空欄ですが、フリガナを取得する関数が入ったセルが約400行分が上の行を占め、その見た目が空欄のセルの下に、思い通りに、カナの頭に数字を入れた施設が並び、その下にフリガナだけの施設がありました。

私の勘違いで、出来ない　と　お騒がせして、大変申し訳ありませんでした。

できましたら、フリガナについて、良い方法を教えていただけないでしょうか。

・ＶＢＡに頼って申し訳ないのですが、関数は消し、Ｂ列に入力されたら、Ａ列にフリガナを表示するというＶＢＡを貼れば良いのではと思いましたが、ＶＢＡがよくわかりません。　ＶＢＡ辞典は、Application.GetPhoneticと載っているのですが、用例がフォーム上のフリガナ取得についてなので、当てはめることが難しく、うまくいきません。

・関数を使っても、ソート時に「関数だけが入っている空白セル」が上の行に来ない方法（関数に工夫を加えるべきでしょうか。IF関数を使って、隣のＢ列が空白だったら、空白で、隣に文字が入力されたら振り仮名を表示する）を考えましたが、ＩＦ関数がうまくいきません。処理速度も遅く、関数でフリガナはまずいかなと思い始めました。

すみません。出来ましたら、フリガナ取得のＶＢＡを教えていただけないでしょうか。

教えていただきたいのは、

・Ｂ列に文字がを入力したら、その行のＡ列（左のセル）にフリガナを表示するということ　と、

・Ｅ列に文字がを入力したら、その行のＤ列（左のセル）にフリガナを表示するということ　です。

今、シートレイアウトを変更して、シート施設はＡ列からＣ列までを新規に挿入しようと思っています。新規レイアウトは、Ｅ列が漢字の施設名で、Ｄ列（左のセル）にフリガナを表示しようと思っているのです。

私の変な関数でご迷惑をおかけした上にさらにお願いをして申し訳ないのですが、どうか教えていただけるでしょうか。

お願いいたします。

回答No.7

onlyrom

レイアウト、拝見。
おや、まあ、（笑）という感じですが、「質問のレイアウト」と当方のレイアウトでは肝心なところは合ってますので、エラーが出るはずはないと、コードのセルＣ３をＣ２へ変更して実行したところ●当然のように（笑）●上手く動作しました。

が、今更それを言っても詮無きことですので、早速新しいレイアウトについて。

●以下、処理の流れを再度確認と質問です。

（０）シート「施設」のＤ～Ｆ列にオートフィルターが設定されていますが、これはあまり意味があるようには思えませんが何のためにあるのでしょうか。

（１）シート「名簿」の該当行を右クリックでシート「施設」のセルＣ２に「氏名」をセットし、シート「印刷」に必要情報をセットする

（２）シート「施設」がアクティブになった時点でセルＣ２の利用者が以前利用した施設を上部に、また以外は５０音順に表示しておく

（３）該当施設の行を右クリックすることにより、セルＣ２の利用者を該当施設の、Ｆ列以降に代入する。が、利用者が以前同じ施設を利用していたら、Ｆ列以降の代入はしない。要するにＦ列以降に利用者名のダブりはないようにする。
シート「印刷」シート「管理簿」に必要データを代入する

（４）印刷が済んだあと、セルＣ２の名前は消去するのかどうか、またその時点でアクティブシートはシート「施設」のままでいいのか。

（５）シート「名簿」「施設」とも行のクリックとありますが、
この行の右クリックとは、画面左の「行番号」の右クリックで行全体を選択するのではなくて、該当行の「セルのどれかひとつ」を右クリックということですね。
質問者のコードではシート「名簿」では行全体でもいいようになっていましたが、シート「施設」ではＡ列Ｂ列どちらかのセル、となっていましたので確認です。

（６）お尋ねの、シート「名簿」「施設」の４行目の空白行は、コードでは問題ありませんが、「手動」でのソートでは範囲を選択してソートしないとソートできません。

４行目の空白を選択ミスの時に使うというアイデアは面白いですねぇ。

これらのことを早めに補足していだだければ解決はもう直ぐそこです。
頑張りましょう。

尚、教えてGoo!では、個人のファイル等へのリンクは禁止されているみたいです。
他の大手の掲示板ではそこらあたりは個人の自己責任に委ねませう、というスタンスなんですがねぇ。
今回のような場合には特に、おい、おい、と言いたくはなります。。(^^;;;

以上です。

補足

ありがとうございます。私は、お礼欄が削除されたと知ったときは、大変ショックを受けました。　引き続き、ご助言をいただき、大変嬉しいです。

確認事項ですが、

（０）シート「施設」のＤ～Ｆ列にオートフィルターが設定されているのは、私がオートフィルターの設定方法を良く知らないせいで、全体にかけてしまいました。
まったく意味はありません。列Ａ～Ｃを選択してからオートフィルターをかければよいのですね。
ご指摘で気付きました。

（１）シート「名簿」の該当行を右クリックでシート「施設」のセルＣ２に「氏名」をセットし、シート「印刷」に必要情報をセットする

はいそうです。　そして、シート「施設」にチェンジさせます。

（２）シート「施設」がアクティブになった時点でセルＣ２の利用者が以前利用した施設を上部に、また以外は５０音順に表示しておく
はいそうです。　　ただ、特定利用施設だけは50音準の上に配置したいので、カナの上に数字を振りました。
　　　・セルＣ２の利用者が以前利用した施設
　　　・カナに数字の入っている施設（数字順）
　　　・カナの50音順
に並べたいのです。　ソートは　数字－カナの順ですよね？

（３）該当施設の行を右クリックすることにより、セルＣ２の利用者を該当施設の、Ｆ列以降に代入する。が、利用者が以前同じ施設を利用していたら、Ｆ列以降の代入はしない。要するにＦ列以降に利用者名のダブりはないようにする。
シート「印刷」シート「管理簿」に必要データを代入する

はい。まったくそのとおりです。

（４）印刷が済んだあと、セルＣ２の名前は消去するのかどうか、またその時点でアクティブシートはシート「施設」のままでいいのか。

　　・Ｃ２の名前は消去しません。
　　・アクティブシートはシート「施設」のままでいいです。

　というのは、同じ利用者が複数の施設を利用手続きすることが多いので、シート施設の画面で、複数の施設を続けざまに右クリックして、必要なだけ利用券を印刷したいのです。

（５）シート「名簿」「施設」とも行のクリックとありますが、
この行の右クリックとは、画面左の「行番号」の右クリックで行全体を選択するのではなくて、該当行の「セルのどれかひとつ」を右クリックということですね。

　　はいそうです。該当行の「セルのどれかひとつ」＝行全体ということです。
　　シート「施設」も該当行の「セルのどれかひとつ」＝行全体の方が操作はしやすいと思い直しました。

（６）お尋ねの、シート「名簿」「施設」の４行目の空白行は、コードでは問題ありませんが、「手動」でのソートでは範囲を選択してソートしないとソートできません。

　ありがとうございます。　４行目の空白行は、スペースを一文字入れるか、削除したいと思います。（最下段の行を利用すればよいことですし）

本当に、感謝の気持ちでいっぱいです。

自分でも勉強したいと思いますので、よろしくご指導ください。

回答No.6

onlyrom

またまたこんにちは。

エラーが出たということですが、こういった類の質問ではままあることです。
何故なら回答する方は質問の文言からシートレイアウトを類推しそれでテストをし、上手くいったからコードアップとなるわけですが、そのレイアウトと実際のレイアウトが違っていることの方が多いからです。それでも肝心のところがあっていたら上手くいくわけですが。
特にＶＢＡの場合はセル番号がひとつずれただけでエラーになることがありますので、詳しい情報、実際のシートレイアウトの情報が必要になります。

ああだこうだとの遣り取りも面白いものではありますが、質問者にとっては少しでも早く完成を急ぎたいでしょうから、その為に実際使っているそれぞれのシート（一応、名簿、施設シートだけでいい）のレイアウトをアップしてください。

コードで使用していない項目もですよ！

シート「施設」には、Ａ列（カナ）Ｂ列（施設名）の２列しかないようになっているが、実際は施設の電話番号とかもあるのでは、とか、
シート「名簿」はＦ列から始まっているが、その以前の列（Ａ～Ｅ列）には他の項目はないのか等など、と思ったりもします。

それからレイアウトを投稿するときは、数回チェックをし間違いがないことを確認してから投稿して下さいな。(^^;;;

頑張りましょう。

以上です。

お礼

暖かく、嬉しい励ましのお言葉をありがとうございます。

おっしゃるとおり、説明がまったく足らず、お手をわずらわせてしまっています。大変申し訳ありません。

不備は、マクロでソートすると「元に戻す」キーで戻せないため、ソート前の状態に戻らないことです。
そこで、シート「施設」にＡＢＣ列を挿入し、Ａ列に通し番号を振れば、後から「並び替え」機能で元に戻せると思いました。
（また、途中で変更してしまい、すみません。もう変更しませんので、どうかご勘弁ください）

また、このエクセル操作は、クリック回数を極力少なくしたいのです。
例えば、名簿も施設も画面の上に表示してある場合なら、名簿の該当者の行を右クリックして情報取得し、自動でシートチェンジし、施設名の行をクリックして情報を取得し、印刷し、管理簿に記録する。
これが、最短２クリックでできるようにしたいのです。

それには、メッセージボックスでの確認などはなくても進むようにしたいのです。（間違って操作してしまったら、最初からやり直すということで対処したいと思っています）

ここまで面倒を見ていただいて、本当に感謝の申しようもありません。
ありがとうございます。

よろしくお願いいたします。

補足

シート「名簿」のレイアウトについて。

タイトルです。
A列は本日 B列は会員番号 C列は入会日 D列は退会日 E列は続柄コード F列はカナ氏名 G列は市町村 H列は大字・番地 I列はアパート J列は漢字氏名 K列は年齢計算 L列は性別 M列は続柄 N列は誕生日 O列は担当者 P列は電話 が入っています。

行１はタイトルが入っています。 行2は空白です。 これは、誤って選択した場合、この行を選択することでシート「印刷」に空白がコピーされるように設けました。（実際は、「上書き保存」で個人情報は消えるＶＢＡを設けたので、必要なくなりましたが）
行３以降は個人情報が入っています。 ただ、Ａ列だけは、年齢計算用の本日の日付を入れているので、行４以下は空欄です。 列Ｄは退会日なのですが、ほとんど空欄です。

列Ｋの年齢は、本日の日付と生年月日から計算して表示しています。=IF(ISERROR(DATEDIF(O4,$B$3,"Y"))=TRUE,"",DATEDIF(O4,$B$3,"Y"))です。
例として、下記の様に表示されています。　年齢は、コピーしたら表示されませんでした。計算させているからでしょうか。　　エクセル上は、越谷　太郎さんは４８歳、草加　次郎さんは２３と表示されています。

行3　　　2007/1/31　　　159　　　S58.5.24　　　1　　　コシガヤ タロウ　　　埼玉県越谷市　　　大字下間久里２８　　　ガーデンヒル２号室　　　越谷　太郎　　　男　　　世帯主　　　昭和33年3月3日　　　鈴木　一郎　　　048-986-0101

行4　　　　　　　　　　　1000　　　H1.1.8　　　1　　　ソウカ ジロウ　　　埼玉県草加市　　　旭町6-13-20　　　勤労会館1階　　　草加　次郎　　　男　　　世帯主　　　昭和58年9月24日　　　鈴木　一郎　　　048-942-2622

シート「施設」のレイアウトについて。（スミマセン。質問後にＡ列、Ｂ列、Ｃ列を加えました。ソート後にも当初の順番に戻せるように番号を設けたためです）

A列は施設No.　　　B列は備考1　　　C列は所在地　　　D列は施設（カナ）　　　E列は施設（漢字）　　　F列は選択されている利用者　　　となっています。

ただ、A2:D3は空欄です。E2も空欄で、F2が「選択されている利用者」の表示セルです。
E3は操作説明文に使い、F3は利用月選択で、入力規則によりリスト選択しています。

タイトルにはないのですが、F3の選択リスト用に、セルＨ２とＨ３：Ｔ３を使用しています。　この列は、４行目以降は空欄です。

行4は空白セルです。（施設名を空欄で印刷させるためですが、最下行をクリックすればよいので、この行4に設けなくてもよかったかもしれません）

行5以下に施設データが入ります。現在、B列の備考1は使用していません。

A列は施設No.　　　B列は備考1　　　C列は所在地　　　D列は施設（カナ）　　　　　　　　　E列は施設（漢字）

1　　　　　　　　　　　　　　　　　　　　　　　　　　越谷市　　　　0010コシガヤボール　　　　　　　　　　　　越谷ボール
2　　　　　　　　　　　　　　　　　　　　　　　　　　草加市　　　　0020ソウカスパリゾート　　　　　　　　　　草加スパリゾート
3　　　　　　　　　　　　　　　　　　　　　　　　　　八潮市　　　　0030ヤシオフィッシングセンター　　　　　八潮フィッシングセンター
4　　　　　　　　　　　　　　　　　　　　　　　　　　八潮市　　　　0040ヤシオフィッシングプラザ　　　　　　八潮フィッシングプラザ
5　　　　　　　　　　　　　　　　　　　　　　　　　　三郷市　　　　0050ミサトタウンプラザ　　　　　　　　　　三郷タウンプラザ
6　　　　　　　　　　　　　　　　　　　　　　　　　　吉川市　　　　ヨシカワナマズゴウ　　　　　　　　　　　　吉川なまず号
7　　　　　　　　　　　　　　　　　　　　　　　　　　吉川市　　　　フードプラザヨシカワ　　　　　　　　　　　フードプラザ吉川

ここで、カナ施設名の頭に番号を入れたものと番号のないものがありますが、番号があるものは、過去に利用がなくても、多くの方が利用しているために、有力候補として上のほうの行に表示したいため、番号を振ったことと、関連施設となっているので、例えば0030と0040は利用者は必ずといっていいほど両方利用するので、近い番号をつけて、ソートしても離れないようにしました。
（ソートの基準をカナ施設名にすることを考えました。）

つたない説明ですが、よろしくお願いいたします。

回答No.5

onlyrom

サンプルコードです。
必ず、該当ブックのコピーを取ってから試してください。

■シート名簿■
-----------------------------------------------------------
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, 　Cancel As Boolean)

　If Target.Count > 1 Then Exit Sub
　If Target.Column <> 10 Then Exit Sub
　If Target.Row < 3 Then Exit Sub

　Cancel = True

　If Target.Value = "" Then Exit Sub

　With Sheets("印刷")
　　.Range("E15:E17").Value = _
Application.Transpose(Cells(Target.Row, 7).Resize(, 3).Value)
　　.Range("AA16").Value = Cells(Target.Row, 10).Value
　　.Range("AQ16").Value = Cells(Target.Row, 11).Value
　　.Range("AX16").Value = Cells(Target.Row, 12).Value
End With

　With Sheets("施設")
　　.Range("C3").Value = Cells(Target.Row, 10).Value
　End With

　Sheets("施設").Select
End Sub
---------------------------------------------------------------

■シート施設■ シートがアクティブになったとき
---------------------------------------------------------------
Private Sub Worksheet_Activate()
　Dim myRange As Range
　Dim FindCell As Range
　Dim LastRow As Long
　Dim LastClm As Integer
　Dim R As Long

　If Range("C3").Value = "" Then Exit Sub

　LastRow = Range("A65536").End(xlUp).Row

　Range(Cells(5, "C"), Cells(LastRow, "C")) = 0

　For R = 5 To LastRow
　　Set FindCell = Rows(R).Find(what:=Range("C3").Value, LookIn:=xlValue, LookAt:=xlWhole)
　　If Not FindCell Is Nothing Then
　　　　Cells(FindCell.Row, "C").Value = 1
　　End If
　Next R

　If WorksheetFunction.CountIf(Range("C5:C" & LastRow), 1) = 0 Then Exit Sub

　LastClm = 3

　For R = 5 To LastRow
　　If LastClm < Cells(R, "IV").End(xlToLeft).Column Then
　　　　LastClm = Cells(R, "IV").End(xlToLeft).Column
　　End If
　Next R

　Set myRange = Range("A5", Cells(LastRow, LastClm))

　myRange.Sort Key1:=Range("C5"), Order1:=xlDescending, _
　　　Header:=xlGuess, OrderCustom:=1, MatchCase:=False

End Sub

'------------------シート右クリック------------
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

　Dim Msg
　Dim myRange As Range
　Dim LastClm As Integer

　If Target.Count > 1 Then Exit Sub
　If Target.Column > 2 Then Exit Sub
　If Target.Row < 5 Then Exit Sub

　Cancel = True

　If Target.Value = "" Then Exit Sub

　If Range("C3").Value = "" Then
　　MsgBox "会員が選択されていません", vbCritical + vbOKOnly
　　Sheets("名簿").Select
　　Exit Sub
　End If

　Msg = MsgBox("施設は、" & Cells(Target.Row, "B").Value & " でいいですか？", _
　　　　　　　vbInformation + vbYesNo, "処理確認")
　　　If Msg = vbNo Then
　　　　MsgBox "正しい施設を選択してください", vbOKOnly, "確認"
　　Exit Sub
　　　End If

　LastClm = Cells(Target.Row, "IV").End(xlToLeft).Column
　Set myRange = Range(Cells(Target.Row, "C"), Cells(Target.Row, LastClm))
　If WorksheetFunction.CountIf(myRange, Range("C3").Value) = 0 Then
　　　Cells(Target.Row, LastClm + 1).Value = Range("C3").Value
　End If

　Sheets("印刷").Range("C10").Value = Cells(Target.Row, 2).Value

　With Sheets("管理簿").Range("A65536").End(xlUp)
　　.Offset(1, 0).Value = Date
　　.Offset(1, 1).Value = Sheets("印刷").Range("C10").Value
　　.Offset(1, 2).Value = Sheets("印刷").Range("AA16").Value
　　.Offset(1, 3).Value = "１"
　　.Offset(1, 4).Value = "窓口印"
　　.Offset(1, 5).Value = "窓口担当"
　End With

'Worksheets("印刷").PrintOut

　Worksheets("印刷").PrintPreview　'テスト用印刷プレビュー

　Range("C3").ClearContents
　Sheets("名簿").Select
End Sub
---------------------------------------------------------

■注意事項と全体の流れ■

（１）「名簿シート」の「氏名」セルの右クリックで、「氏名」を「施設シート」のセル”Ｃ３”に代入、及び必要項目を「印刷シート」の該当セルに代入し、「施設シート」をアクティブにする

（２）「施設シート」の列Ａ（カナ）列Ｂ（施設名）の右クリックで、「印刷シート」「管理簿シート」に必要事項を代入し印刷し、印刷が終わったら、セルＣ３の名前をクリアーし、「名簿シート」に戻る

●ここからが機能追加の部分●
（３）上記（２）の時点で、クリックした施設名と同じ行の、Ｄ列以降（Ｄ，Ｅ，Ｆ。。。）に、今回の利用者、セルＣ３の値をセットする。

（４）説明が前後しますが、今回の利用者が以前利用した施設があった場合その施設を最初の方に表示させるために並べ替えを使っています。

並べ替えのキー列をＣ列とし、セルＣ３の利用者が以前利用していた施設と同じ行のＣ列に、１、を立て、また利用していない場合は０になるように検索の前に全てに０をセットして、検索が終了したら、Ｃ列で降順に並べ替えしています。
そしてこれらは全て、上記（１）のあと「施設シート」がアクティブになったときの処理です。

一応、テストはしてありますので安心して試してみてください。

いや～、文字での説明は難しいっ！(^^;;;
乗りかかった船ですので完成までお付き合いしませう。
以上です。

お礼

すみません、こちらも文字数が足りないので、■シート名簿■のコードは
省きます。このシートも(C3)を(C2)に変更してしまいました。

■シート施設■ シートがアクティブになったとき
Private Sub Worksheet_Activate()
　Dim myRange As Range
　Dim FindCell As Range
　Dim LastRow As Long
　Dim LastClm As Integer
　Dim R As Long

　If Range("C2").Value = "" Then Exit Sub

　LastRow = Range("A65536").End(xlUp).Row

　Range(Cells(5, "C"), Cells(LastRow, "C")) = 0

　For R = 5 To LastRow
　　Set FindCell = Rows(R).Find(what:=Range("C2").Value, LookIn:=xlValue, LookAt:=xlWhole)
　　If Not FindCell Is Nothing Then
　　　　Cells(FindCell.Row, "C").Value = 1
　　End If
　Next R

　If WorksheetFunction.CountIf(Range("C5:C" & LastRow), 1) = 0 Then Exit Sub

　LastClm = 3

　For R = 5 To LastRow
　　If LastClm < Cells(R, "IV").End(xlToLeft).Column Then
　　　　LastClm = Cells(R, "IV").End(xlToLeft).Column
　　End If
　Next R

　Set myRange = Range("A5", Cells(LastRow, LastClm))

　myRange.Sort Key1:=Range("C5"), Order1:=xlDescending, _
　　　Header:=xlGuess, OrderCustom:=1, MatchCase:=False

End Sub

'------------------シート右クリック------------
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

　Dim Msg
　Dim myRange As Range
　Dim LastClm As Integer

　If Target.Count > 1 Then Exit Sub
　If Target.Column > 2 Then Exit Sub
　If Target.Row < 5 Then Exit Sub

　Cancel = True

　If Target.Value = "" Then Exit Sub

　If Range("C2").Value = "" Then
　　MsgBox "会員が選択されていません", vbCritical + vbOKOnly
　　Sheets("名簿").Select
　　Exit Sub
　End If

　文字数により、以下が書けません。スミマセン
もし、回答をいただいて、お礼欄が設けられましたら、また入力します。

補足

暖かいお言葉を本当にありがとうございました。また、私が誤った質問文を書いて余計混乱させてしまい、本当に申し訳ございませんでした。

シート「名簿」で選択した氏名を、確認のためにシート「施設」に転記した場所は、セル「Ｃ３」ではなく、セル「Ｃ２」でした。

また、いただいたコードでは、シート「名簿」の氏名選択はＦ列のみを右クリックすると作動するようになっていますが、「その行」のどこでも右クリックすると作動するようにしたいのですが、それはどうすればよいでしょうか。

　　　If Target.Column <> 10 Then Exit Sub
　これでＦ列を指定しているのだと思いますが、どう変えればよいのでしょうか。

C3とされていたものをC2として貼り付けたところ、

実行時エラー'9'
インデックスが有効範囲にありません

と出て、デバックをクリックすると

シート「施設」の
Set FindCell = Rows(R).Find(what:=Range("C2").Value, LookIn:=xlValue, LookAt:=xlWhole)

が黄色くマーカー表示されます。

勝手に一部を変えたのがいけなかったのだと思います。
下記のように貼り付けました。

恐れ入りますが、再度ご指摘いただけるでしょうか

文字数が足りないので、貼り付けたコードは「お礼欄」に記載します。
失礼とは存じますが、両方目を通してください。

出来ましたら、もうしばらくご指導いただきたいので、よろしくお願いいたします。

回答No.4

cafe_au_lait

いろいろ考えた結果、質問者様のやり方の方がすっきりすることが分かりました。No.1の回答は無視してください。ただ、利用者が多すぎると列の最大値を超えます。

まず、シート「施設」のC列に、過去の利用の有無を判定する関数を入力します。
C5:=IF(COUNTIF($D5:$IV5,$C$2)=0,"無","有")
下へコピーします。

【シート「名簿」のコード（途中から）】

With Sheets("施設")
.Range("C2").Value = _
Me.Cells(Target.Row, 10).Value
.Select
.Range("5:" & .Range("A65536").End(xlUp).Row) _
.Sort Key1:=.Range("C5"), Order1:=xlDescending, _
key2:=.Range("B5") '並べ替え
Cancel = True
End With
End Sub

【シート「施設」のコード（途中から）】

Worksheets("印刷").PrintOut

If Target.EntireRow.Find(What:=Me.Range("C2").Value, _
Lookat:=xlWhole) Is Nothing Then '利用者名の有無をチェック
Target.End(xlToRight).Offset(, 1).Value = _
Me.Range("C2").Value '施設名を末尾に追加
End If
End Sub

もし並べ替えが逆順になる場合は、Order1:=xlDescendingの部分を消去してくさい。

お礼

うまく出来ました。大変ありがとうございました。

当初考えていたのは、該当施設だけが上の行に抜き出され、他の施設は当初の入力順により下の行に表示されているということを考えていましたが、これのほうが、５０音順になるので好都合かもしれません。

ありがとうございました。

補足

出来た後で、少し欲が出てしまい、再度お尋ねします。

ソートの基準をセルＡ列（セルＡ５以下）にするにはどうしたらいいのでしょうか？

シート「名簿」のコードの
key2:=.Range("B5") '並べ替え　　を
key2:=.Range("A5") '並べ替え　　にすれば良いのかと思ったので勝手にいじってみましたが、過去にその会員が利用している履歴があるセルは残ったのですが、その他の施設が消えてしまいました。
コードを　key2:=.Range("B5") 　に直して、名簿の会員名を右クリックしたところ、消えていた施設名もすべて出てきました。

今回Ａ列にしたくなったのは、「この施設」と「この施設」はペアで利用するという施設があったため、フリガナ施設名の上に数字を振りました。

例えば、東京温泉と港区リゾートがペアで利用する場合、
　Ａ列　　　　　　　Ｂ列
0010トウキョウオンセン　　東京温泉
0020ミナトクリゾート　　港区リゾート
としました。
フリガナについては、関数を利用し、
="0010"&ASC(PHONETIC(B5))として表示しているセルが約４０行続き、
その後は結びつきのある施設はないので、
=ASC(PHONETIC(B50))として表示しています。

それとも、いっそのことシートを作り直して、
フリガナはＦ列に、漢字名はＧ列にして、過去の利用判別をＨ列にして、取得した過去の利用者のコピーをＩ列以降にすれば、フリガナＦ列をソートの基準としても、利用履歴のあるセル以外の行も表示されるでしょうか。

すべての施設が表示されないと、ある会員が、「今日からこっちも利用しよう」と言った場合、選択できないことになります。

すみません。もう少しだけ教えていただけるでしょうか。
よろしくお願いします。

回答No.3

onlyrom

こんにちは。再度の登場です。

＞セルＣ３については、シート「施設」のセルＣ３に、現在選択している利用者がシートチェンジ後も分かるように

提示のコードでは、「セルＣ３」となってますが、最初の質問では以下のように、「セルＣ２にコピー」となってますので、本当はどっちですか、とお訊ねしたわけです。

＞＞ＶＢＡにより、シート「会員」の該当者の「行」を右クリックすると個人情報がシート「印刷」の指定位置とシート「施設」の●セルＣ２●にコピーされ、

それからチェックの件は、誤って名簿の「名前セル」を右クリックしたときのエラー処理のことです。
施設シートでは、少なくともそれはやっておられますから。

ま、一応それはそれとして、サンプルコードを書きましたので連続投稿します。

　　　続く。

お礼

大変スミマセン。まったく同じ間違いをしてしまい、赤面してしまいました。

おっしゃるとおり、質問文が間違っています。
正しくは　セルＣ２　です。

セルＣ２　に、前のシートで選択した人が誰だか確認できるように、名前をコピーしています。

すみませんでした。