[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『指定範囲内で指定した文字列を表示させた時に(?U)』（ちぃさん）
すみません。
[[20150306131532]]
コチラの続きになります。
ご指摘されてる部分も追加し質問いたします。
Sheet1
__A__ ____B____ ____C____ __D__ ____E____ ____F____ ____G____ ____H____ 1 日時 合計 美装時間 2 1 1 11:30 3 4 5 6 1日 9:00 ｴｸｾﾙ aa 100 7 1日 9:15 8 1日 9:30 〜 16 1日 11:30 美装 17 1日 11:45 18 1日 12:00 ｴｸｾﾙ ab 1 19 1日 12:15 〜 100 1日 8:45 101 2日 9:00 102 2日 9:15 . . . . . .
すみません。
今気づきましたがアップしたマクロ誤りがありました。
正しくは
Private Sub Worksheet_Change(ByVal Target As Range)
Dim re '最終行
Dim cp '転記列
Dim tr '変更セル行番号
Dim s '開始行
Dim rc2 As Integer
If Target.Address = "$F$2" Then
rc2 = MsgBox("日時を転記しますか？", vbYesNo + vbQuestion, "確認")
If rc2 = vbYes Then
MsgBox "処理します"
With Sheets("Sheet2")
s = 22
cp = 2
re = .Cells(30, cp).End(xlUp).Row
If re < s Then re = s + 3
.Cells(re + 1, cp) = Now()
Range("H2").Value = Range("E" & Rows.Count).End(xlUp).Offset(, -2).Value
End With
Else
MsgBox "処理を中断します"
End If
End If
End Sub
こちらです。
Sheet1はこのような感じで3000行までいきます。
B6:B3000までとC6:C3000までは初めから日付と時間を入力しており、このシートを使う際に入力する場所はE6:E3000とF6:F3000とG6:G3000までの間で必要な部分のみ入力していきます。
F2には入力規則で日付を入力するようにしてます。
G2には計算式が入ってます。 G2=SUMPRODUCT((C6:C3000>=H2)*(E6:E3000="ｴｸｾﾙ"),G6:G3000)
H2にはC列の時間を転記したものです。
E6:E3000の入力方法にも入力規則をつかってます。
＞その同じブックにある SHeet2 のレイアウトを教えてほしんです。
＞何列目の何行目から何行目まで、何がはいっている。
Sheet2は [[20150306131532]] にもかいていますが提出用の記録用紙なので本来は美装した日時を手書きで書き込むものなのですが手間なのでマクロで転記させています。
転記位置はアップしたマクロの範囲でB26:B30の所だけがいいです。
他の部分に転記されると書類として使えなくなるのでこの部分に指定しています。
＞どうもよくわかりません。
＞「F2 には「ﾜｰﾄﾞ」が入力された時間を転記させれるように簡単にではありますがマクロをセットしています。」
＞ということですが、マクロでやっていることは E列にいれられるエクセルとかワードといったものとは全く関係なく
＞ F2 に 「何か（ＡＢＣでも１００でも）」が入力されたら、Sheet2のB列に、「その時の時間（Ｆ２に入力された時間）」を記載しています。
この部分も最初の私の説明がわるく申し訳ございません。
「指定範囲内で指定した文字列を表示させた時に指定したセルに変化がなければメッセージ表示」
が目的でしたので本来は「美装」を指定する文字列は「ﾜｰﾄﾞ」とさせていただいてました。
わかりづらくさせてしまい申し訳ありません。
ご指摘されているとおりアップしたコードは時間を記録させるためにだけに転記させているものです。
今回訂正させていただいたコードが正です。
＞F2 には、どういったときに何をいれるのかがわかりませんねぇ。
F2はG2に表示されている数字が上限を超えるまえに美装できるようにしています。
訂正したコードでE列の最下行を検索し、その時間をH2に転記。
G2はその転記された時間以降を加算していく。
そして美装日時を提出用の用紙に転記。
このような感じです。
＞現行の構えを活用できればそうしますが、その前に、やはり、何をしたいのか、１から順を追って説明していただく必要がありますねぇ。
入力者が順番どおりに
E列に美装を入力⇒F2に美装日を入力
としてくれれば問題ないのですが F2 の入力をしない人（忘れる?)がいるのです。
美装しているのに F2 の入力を忘れてしまっていたため上限を超えてしまい不良品扱いとなったり又は、美装をしているのにまた美装をしてしまい二度手間となったり。。。。
ということを避けるために指定した文字列「美装」がE6:E3000の間に1回でも入力されたのちF2のセルに変化がないまま再びE6:E3000の範囲に入力をすれば
「F2は変更しましたか？」
とメッセージを出したいです。
まだ説明不足がありましたらご指摘きださい。
どうぞ宜しくお願い致します。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
深夜の整理作業と投稿、ご苦労様です。 これから、もう一度、こちらでも、整理してみます。 また、わからないことがあれば逆質問すると思いますが、がんばって解決させたいですね。
（β） 2015/03/07(土) 07:09
宜しくお願い致します。
（ちぃさん） 2015/03/07(土) 08:58
まだ、よくわからないところもありますが まず、コードはそのままで、インデントを整理し、データ型は明示したほうがどんな変数かが見た目でわかりやすいのでそこを追加。 また、お気づきかどうか、F2 に範囲外の日付、あるいは日付以外をいれると、入力規則でエラーになりますが そこで再試行を選び正しい日付をいれたとしますと、
・最初の間違い入力 ・入力規則内での取り消し（裏で自動に処理） ・正しく打ち直した入力
この３回の入力が F2 に対して行われ、結果、Changeイベントも３回発生（いわゆるイベントの連鎖）して マクロ処理も３回おこなわれます。（メッセージも３回でます）
最終的には処理そのものには悪影響を与えませんが、ここも何とかしたいと思います。 (通常なら Application.EnableEvents を False にすることで回避しますが、このケースでは、正常入力が終わった後に まとめて複数回のイベント発生となるので、ちょっとやっかいですが、少し考えてみます）
それと、「美装」の管理なのに、 =SUMPRODUCT((C6:C3000>=H2)*(E6:E3000="エクセル"),G6:G3000) 「エクセル」の回数をカウントしているのが気になりますが、ここは要件がわからないので何とも言えません。 また、H2 に書き込んでいる時間は、たまたま、その時点のE列の最後のセル（アップされた例では「エクセル」）の時間ですが？ さらに、Sheet2に記載している時刻も「美装」の時刻ではなく、その時のマクロ処理時刻ですけど、よろしいのですか？
まったく、とんちんかんなコメントかもしれませんが、今の構えを忘れて
E列に 何か入力されたら、その時点の 最後の「美装」の情報から F2 と H2 に 書き込み、 Sheet2の情報も、Sheet1の「美装」の情報から洗い替える
こういうことなんじゃないのかなぁ・・・と思いますが？ いかがですか？
いずれにしても、現在のコードのままですけど、データ型を追加しインデントを整理したものを以下に。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim re As Long '最終行
Dim cp As Long '転記列
Dim tr As Long '変更セル行番号
Dim s As Long '開始行
Dim rc2 As VbMsgBoxResult
If Target.Address = "$F$2" Then
rc2 = MsgBox("日時を転記しますか？", vbYesNo + vbQuestion, "確認")
If rc2 = vbYes Then
MsgBox "処理します"
With Sheets("Sheet2")
s = 22
cp = 2
re = .Cells(30, cp).End(xlUp).Row
If re < s Then re = s + 3
.Cells(re + 1, cp) = Now()
Range("H2").Value = Range("E" & Rows.Count).End(xlUp).Offset(, -2).Value
End With
Else
MsgBox "処理を中断します"
End If
End If
End Sub
（β） 2015/03/07(土) 09:09
追伸です。
現在、Sheet1に一か月分の行が15分おきに3000行（ほんとは 2日 は 101行目ではなく 102行目？） 配置しておられますが、管理そのものは、「その日」の 「美装」管理ですよね。
たとえば、今日、7日に、 3日の記入に間違いに気が付き、それを訂正するケースもありえますよね。
ここは、（面倒かもしれませんが）日別にシートをわけられてはいかがですか？ その場合でも、現在Sheet1のシートモジュールに書いてあるロジックを各シート毎に書く必要はなく ThisWorkbookモジュールに、まとめて一本化することができます。
このほうが、入力者も、ずずずっとシートをスクロールしなくてもすむと思うんですが？
（β） 2015/03/07(土) 09:21
＞「エクセル」の回数をカウントしているのが気になりますが、ここは要件がわからないので何とも言えません。
「エクセル」の入力のあるG列を加算し上限を超す前に計算をリセットさせたいので「エクセル」をカウントしています。
上限は条件付き書式を使い色づけをしています。
仮に上限が1000であれば加算された結果が800を超えるとG2が赤くなるようになってます。
G2が赤く表示されれば「美装」時期が近いので美装しG列の計算をリセットさせて美装後、新たに計算を始めるような感じです。
＞また、H2 に書き込んでいる時間は、たまたま、その時点のE列の最後のセル（アップされた例では「エクセル」）の時間ですが？
H2に書き込んでいる時間は C16 の 11:30 の「美装」が入力されているとおもうのですが。
C16 の 11:30 の「美装」が入力されているので G2の合計は C16 の 11:30 より下の C18 の 12:00 「エクセル」の 1 だけが計算されていると思うのですが。
＞さらに、Sheet2に記載している時刻も「美装」の時刻ではなく、その時のマクロ処理時刻ですけど、よろしいのですか？
「美装」頻度は1〜2週間程度に1回程度になります。
現在のマクロ処理はF2を入力した時のE列の最下行に並ぶC列の時間が転記されます。
C列の時間は15分単位なので少しズレますが数分ズレてもG2に加算される数字は多分変わらないし提出するSheet2の書類の日時は日付と大まかな時間で問題ないので現在の形になってます。
＞E列に 何か入力されたら、その時点の 最後の「美装」の情報から F2 と H2 に 書き込み、
＞Sheet2の情報も、Sheet1の「美装」の情報から洗い替える
そのとおりです。
でも私には難しく最後の「美装」をE列から検出する方法がわかりません。
＞現在、Sheet1に一か月分の行が15分おきに3000行（ほんとは 2日 は 101行目ではなく 102行目？）
＞ 配置しておられますが、管理そのものは、「その日」の 「美装」管理ですよね。
「その日」というより1ヵ月のうち「美装」をいつしたのかを管理しています。
＞ここは、（面倒かもしれませんが）日別にシートをわけられてはいかがですか？
現在の形での対応は難しいでしょうか？
＞このほうが、入力者も、ずずずっとシートをスクロールしなくてもすむと思うんですが？
それはおもいます。
1つのシートのほうが後で見やすいと思いまして（汗）
できれば現在の形のまま進めたいのですが。
宜しくお願い致します。
（ちぃさん） 2015/03/07(土) 10:34
要件がまだわかっていないところ多々ありますが、Sheet2の内容をクリアした上で、 現在のコードで、アップされたシートイメージに対して F2 に 1日（2015/3/1 ?) を入れてみてください。 H2 には、どんな時刻が書かれますか？ またSheet2に書き込まれた時刻は、ちぃさんが思い描いている時刻ですか？
>>Sheet2の情報も、Sheet1の「美装」の情報から洗い替える >そのとおりです。 >でも私には難しく最後の「美装」をE列から検出する方法がわかりません。
後ほど参考コードをアップしてみます。
（β） 2015/03/07(土) 14:47
Sheet1のシートモジュールを以下で置き換えてください。
で、Sheet1 の E列のどこかに何でもいいので値をいれてください。 その入力を検知してメッセージを出しています。 このメッセージの内容が、ちぃさんがやろうとしていることに役立つなら、これをベースにした 処理を行うことができます。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
'E列に変更がなければ処理しない
If Intersect(Target, Columns("E")) Is Nothing Then Exit Sub
'変更なったセル領域の最初が6行目未満なら処理しない
If Target(1).Row < 6 Then Exit Sub
Set c = Range("E6", Range("E" & Rows.Count).End(xlUp)).Find(What:="美装", LookAt:=xlWhole, SearchDirection:=xlPrevious)
If c Is Nothing Then
MsgBox "美装が未入力の状態です"
Else
MsgBox "このシートの最後の美装は " & c.Row & " 行目。そのＢ，Ｃ列の値は " & c.Offset(, -3).Text & "/" & c.Offset(, -2).Text & "です"
End If
End Sub
（β） 2015/03/07(土) 15:04
メッセージのでる内容は私が求めている内容です。（嬉）
このメッセージの内容でH2に時間が転記されると「美装」と入力した時点でかならずH2には「美装」と入力したE列と並ぶC列のセルの時間がH2に転記されるので私がしたくてもできなかった内容になります。
でもどのように元のコードを変更すればよいのでしょうか？
チョット変更してみたのですがH2にC列の時間ではなく「美装」の文字列が転記されます。
変更後コード
Private Sub Worksheet_Change(ByVal Target As Range)
Dim re '最終行
Dim cp '転記列
Dim tr '変更セル行番号
Dim s '開始行
Dim rc2 As Integer
If Intersect(Target, Columns("E")) Is Nothing Then Exit Sub
rc2 = MsgBox("日時を転記しますか？", vbYesNo + vbQuestion, "確認")
If rc2 = vbYes Then
MsgBox "処理します"
With Sheets("Sheet2")
s = 22
cp = 2
re = .Cells(30, cp).End(xlUp).Row
If re < s Then re = s + 3
.Cells(re + 1, cp) = Now()
If Intersect(Target, Columns("E")) Is Nothing Then Exit Sub
'変更なったセル領域の最初が6行目未満なら処理しない
If Target(1).Row < 6 Then Exit Sub
Range("H2").Value = Range("E6", Range("E" & Rows.Count).End(xlUp)).Find(What:="美装", LookAt:=xlWhole, SearchDirection:=xlPrevious)
End With
Else
MsgBox "処理を中断します"
End If End Sub
どこが駄目でしょうか？
（ちぃさん） 2015/03/07(土) 15:54
[追加]
あ。。。
Offsetがない（汗）
どこにいれればいいですか？
と言うかいままので Offset いれればいけるのですか？
いけました。
取り急ぎお礼をと思いまして。
コードを1つづつ見直してわからない部分を質問させていただきたいのですが（汗）
手間を取らせて申し訳ないですがどうか宜しくお願いいたします。
（ちぃさん） 2015/03/07(土) 16:15
はい、なんでも聞いてくださいね。
（β） 2015/03/07(土) 16:28
やはりまだ駄目でした。
私の記述に誤りがあるとおもいます。
インデントの付け方が下手で非常に見づらいコードとなってますが。。。。。
現在、
Private Sub Worksheet_Change(ByVal Target As Range)
Dim re '最終行
Dim cp '転記列
Dim tr '変更セル行番号
Dim s '開始行
Dim rc2 As Integer
If Intersect(Target, Columns("E")) Is Nothing Then Exit Sub '※変更部分
rc2 = MsgBox("日時を転記しますか？", vbYesNo + vbQuestion, "確認")
If rc2 = vbYes Then
MsgBox "処理します"
With Sheets("Sheet2")
s = 22
cp = 2
re = .Cells(30, cp).End(xlUp).Row
If re < s Then re = s + 3
.Cells(re + 1, cp) = Now()
If Intersect(Target, Columns("E")) Is Nothing Then Exit Sub '※追加部分
'変更なったセル領域の最初が6行目未満なら処理しない
If Target(1).Row < 6 Then Exit Sub '※追加部分
Range("H2").Value = Range("E6", Range("E" & Rows.Count).End(xlUp)) _
.Find(What:="美装", LookAt:=xlWhole, SearchDirection:=xlPrevious).Offset(, -2).Value '※変更部分
End With
Else
MsgBox "処理を中断します"
End If End Sub
このように変更しています。
まだ駄目な部分というのはE列に「美装」を入力するとC列の時間を転記するのですが、「美装」以外の文字列を入力しても転記しようとします。
正しくは文字列を入力しなくてもE6以降を1度選択するだけで転記しようとします。
時間が転記する前にメッセージがでるので「いいえ」を選択すればマクロ処理は止まりますが。
転記しようとするだけで転記はされませんがちょっとメッセージが。。。。と思いまして。
どの部分がだめでしょうか？
どうか宜しくお願い致します。
（ちぃさん） 2015/03/07(土) 16:51
(追加)
すみません。
E6以降に1度も「美装」がはいっていない状態で
E6以降のセルを選択
E6以降のセルに「美装」以外の文字列を入力
した場合にエラーがでます。
実行エラー91
デバッグで確認しました。
Range("H2").Value = Range("E6", Range("E" & Rows.Count).End(xlUp)) _
.Find(What:="美装", LookAt:=xlWhole, SearchDirection:=xlPrevious).Offset(, -2).Value '※変更部分
この部分でエラーとなってます。
何故でしょうか？
>まだ駄目な部分というのはE列に「美装」を入力するとC列の時間を転記するのですが、「美装」以外の文字列を入力しても転記しようとします。
はい。それは、そういうコードにして提案していますので。 （美装だけをチェックしてもいいのですが、間違えて美装としてしまった。でも、そこは【エクセル】にすべきだった。 あるいは、空白にした とか）
でも、確かに、美装とは関係ないのに、ちょっとうざいな・・というのはわかります。 最終的には、美装か、あるは、前が美装だったけど、それを違う文字列（空白含めて）にしたときのみに 処理するようにしましょう。
>E6以降に1度も「美装」がはいっていない状態で・・・した場合にエラーがでます
おはずかしい（汗） これも訂正して後ほど。
↑★ と書きましたが、参考コードとしてアップしたものは、美装がなくてもエラーにならないはずです。 まぁ、それも含めて後ほど。（18:42)
>正しくは文字列を入力しなくてもE6以降を1度選択するだけで転記しようとします
これは、ないと思いますが？ それとも、シートモジュールに SelectionChangeイベントが別途書かれているとか？
（β） 2015/03/07(土) 18:27
＞↑★ と書きましたが、参考コードとしてアップしたものは、美装がなくてもエラーにならないはずです。
確かにアップしていただいたコードはエラーはでません。
何がだめなのでしょうか？
もしかしてアップしていただいたコード
Set c = Range("E6", Range("E" & Rows.Count).End(xlUp)).Find(What:="美装", LookAt:=xlWhole, SearchDirection:=xlPrevious)
の後の
If c Is Nothing Then
が無いから?でしょうか??
もしそうならどのように追加すればよいでしょうか?
＞これは、ないと思いますが？
言葉が間違ってました。
すみません。
正しくは 「転記しようとします」ではなく「転記しようとした時のメッセージがでます」でした。
すみません。
＞それとも、シートモジュールに SelectionChangeイベントが別途書かれているとか？
現在は今アップしているコードのみの記述となっています。
どうぞ宜しくお願い致します。
（ちぃさん） 2015/03/07(土) 19:33
書いてみました。 不具合あるいは不明点があれば指摘願います。 少し手を抜いています。 美装だったもの（つまり、この時刻はすでにSheet2に書かれているはず）が美装ではなくなった場合、 本来なら、Sheet2に書き込み済みの、対応する美装日時を削除しなければいけませんが そのままにしてあります。
また、勝手に（？）美装がまったくない場合、F2,H2をクリアしています。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim re As Long '最終行
Dim cp As Long '転記列
Dim tr As Long '変更セル行番号
Dim s As Long '開始行
Dim rc2 As VbMsgBoxResult
Dim c As Range
Dim sv As Variant
If Intersect(Target, Columns("E")) Is Nothing Then Exit Sub '※変更部分
'変更になったセル領域の最初が6行目未満なら処理しない
If Target(1).Row < 6 Then Exit Sub '※追加部分
Application.EnableEvents = False '書き込みによるイベント発生を抑止
Application.Undo '変更前に戻す
sv = Target(1).Value '変更前のセルの値
Application.Undo '変更後に戻す
Application.EnableEvents = True 'イベント発生再開
'美装入力あるいは美装入力の変更以外は処理しない
If Target(1).Value <> "美装" And sv <> "美装" Then Exit Sub
rc2 = MsgBox("日時を転記しますか？", vbYesNo + vbQuestion, "確認")
If rc2 = vbNo Then
MsgBox "処理を中断します"
Exit Sub
Else
MsgBox "処理します"
Application.EnableEvents = False '書き込みによるイベント発生を抑止
Set c = Range("E6", Range("E" & Rows.Count).End(xlUp)) _
.Find(What:="美装", LookAt:=xlWhole, SearchDirection:=xlPrevious)
If c Is Nothing Then
'美装がない場合
Range("F2,H2").ClearContents '美装の日と時間欄をクリア
Else
Range("F2").Value = c.Offset(, -3).Value '美装日
Range("H2").Value = c.Offset(, -2).Value '美装時間
End If
Application.EnableEvents = True 'イベント発生再開
If c Is Nothing Then Exit Sub
'Sheet2への書き込み
With Sheets("Sheet2")
s = 22
cp = 2
re = .Cells(30, cp).End(xlUp).Row
If re < s Then re = s + 3
'当該美装の日時
.Cells(re + 1, cp) = c.Offset(, -3).Value + c.Offset(, -2).Value
End With
End If
End Sub
（β） 2015/03/07(土) 20:01
処理内容は完璧ですが一気にコードが難しくなったような（汗）
少し質問させていただきたいです。
1点目
最初のベースとなったメッセージでのコードの時から気になっているのですが
Target(1) の (1)は何を示しているのですか？
理解したいので教えていただけないでしょうか。
2点目
全く見たことのないコードがでてきました。
Application.EnableEvents = False '書き込みによるイベント発生を抑止
Application.Undo '変更前に戻す
sv = Target(1).Value '変更前のセルの値
Application.Undo '変更後に戻す
Application.EnableEvents = True 'イベント発生再開
この部分全くわかりません。
調べてみると
EnableEvents プロパティはイベントを無効にする。とかって書いてました。
Undoメソットは最初に行なった操作を元にもどす。ってかいてました
どうゆうことなのでしょうか？？？？？
よくわからないので試しに
Application.EnableEvents = False '書き込みによるイベント発生を抑止
Application.Undo '変更前に戻す
sv = Target(1).Value '変更前のセルの値
Application.Undo '変更後に戻す
Application.EnableEvents = True 'イベント発生再開
この部分を無効にして動作させると「美装」の入力を全て消してもF2とH2の表示は消去されませんでしたがその他の動作は無効にする前と変化がないようにみえました。
この部分は「美装」の入力がないときにF2とH2の表示を消去させるためのものなのでしょうか？
夜遅くに面倒な質問を申し訳ありません。
時間があるようでしたら教えていただけないでしょうか。
どうぞ宜しくお願い致します。
（ちぃさん） 2015/03/07(土) 21:54
●Application.Enableevents = False/True
新規ブックで、シートモジュールに
Private Sub Worksheet_Change(ByVal Target As Range)
MsgBox "Change"
Range("A1").Value = "ABC"
End Sub
こうして、そのシートの任意のセルに、何か値を入れてみてください。 延々とメッセージがでます。（無限ループに陥ります）
無限ループが確認できたら メッセージがでた時点で Ctrl/Alt/Pause をおして 強制的にコード処理を中断し終了をおしてください。
次に
Private Sub Worksheet_Change(ByVal Target As Range)
MsgBox "Change"
Application.EnableEvents = False '★1
Range("A1").Value = "ABC"
Application.EnableEvents = True '★2
End Sub
シートモジュールコードを、これにして、再度、セルに何か値をいれてください。 今度は無限ループに陥ることはなかったですね。
Changeイベントはセルに何か値が入ると発生します。
で、最初のケースでは、コード内の Range("A1").Value = "ABC" ここでセルに値を入れているので
またもや発生して、そこから、このプロシジャに【再入】します。
で、そこでもまた、Range("A1").Value = "ABC" ですから、イベント発生->再入。
そこでもまた・・・・・
延々と続きます。イベントの連鎖を呼びます。
次のケースでは、セルへの書き込み前に ★1 で、エクセルに対して、イベントを発生させないでくださいと
指令をだします。そうすると、 Range("A1").Value = "ABC" で書き込んでも Changeイベントは発生しません。
で、書き込み後、★2 で、イベントの再開ＯＫと連絡します。
Application.EnableEvents = False として、このプロパティをFalse にすると、エクセル終了まで、ずっと False のままで、次の入力をしてもイベントが発生しないという不具合がでますので、必ず True に戻してやる必要があります。
●Application.Undo
Undoメソッドは、操作で言えば、入力後、「元に戻る矢印」をおすと、入力前の値に戻る、あの機能です。 さらに、操作でいえば、もう一度、「元に戻る矢印」をおすと、さらに、その前の値に戻すこともできますね。 （ちなみに、反対の矢印もあって戻したものを次々に復元していく ReDo もありますが、VBA では、それはありません）
ですから、たとえばセルに ABC と入っていて、それを XYZ に変更する。そうすると、Changeイベントが発生しますが 我々は、Target が XYZ ということしか認識できませんね。XYZ の前は何だったんだろう？ これを、無理やり、元に戻す機能で、入力前の状態に変更します。そうるすと Targetの値は ABC になりますね。
操作でいえば、この後、反対側の矢印で XYZ に戻すところですが、前述の通り、VBA では ReDo がありません。 ただ、幸いなことに（？）この状態でもう一度 Application.Undo をかけますと、XYZ に戻るんです。 おそらくは、ABC(元々あった値）->XYZ（入力した値)->ABC(UnDo で戻した値) この状態になっていて、 ABC(UnDo で戻した値) から UnDo つまり <- ですから、 XYZ になるんだろうと。操作とVBA処理とのちょっとした 仕様の違いを利用しています。
何をやりたかったかというと、美装 の入力もチェックしたかったんですが、たとえば、最後の美装を あぁ、間違っていた、エクセルだったと、打ち直したとしたら、本来なら、その前の美装が最終美装で F2 や H2 を、その前の美装のものに変えなきゃいけない。
なので、変更前が美装だったものも対象にしたくて、このようなことを実行しました。
●Target(1)
ご存じのとおり、Target は変更のあったセルオブジェクトです。（A1 に入力すると、A1セル） 通常の操作では、おそらく、Targetは単一セルでしょう。 でも、以下のような操作をすると、Targetが複数セル領域になります。
・マウスで複数セルを選択して、Deleteキーで値をクリアする ・複数セルを選択して、Ctrl/C 。 で、別のセルを選択して Ctrl/v ・どこかのセルに何か値を入力（この時点では単一セルのイベント） そのあと、このセルを選択して右や下にフィルコピー。
先ほどの、シートモジュールを
Private Sub Worksheet_Change(ByVal Target As Range)
MsgBox Target.Address & vbLf & Target(1).Address
End Sub
こうして、↑の操作をしてみてください。 Target が複数セル、Target(1) は、そのセル領域の最初のセルだということがわかります。
で、シートモジュールをさらに
Private Sub Worksheet_Change(ByVal Target As Range)
MsgBox Target.Address & vbLf & Target(1).Address
MsgBox Target.Value
End Sub
こうして、↑の操作をしてみてください。 エラーになってしまいますね。
本来なら、複数セルを意識して、Targetの中のセルを１つずつ取り出して処理しなければいけないんですが まぁ、そこは手を抜いていて、仮に複数セルだったとしても、その中の先頭のセルしか相手にしていません。 （それは、困る。すべて相手にしてほしい ということであれば、対応しますが？）
（β） 2015/03/08(日) 00:56
後出し的な質問で申し訳ないのですが。。。（汗）
では、もし指定する文字列を増やす場合はどのような変更が必要になるでしょうか？
取り違えていると思うのですが「美装」とは違う文字列「交換」をまた別に指定しようとする場合はご教授頂いているコードを繋げばいいのでしょうか？
試してみました。
内容はご教授いただいたコードを
Private Sub Worksheet_Change(ByVal Target As Range)
から
.Cells(re + 1, cp) = c.Offset(, -3).Value + c.Offset(, -2).Value
End With
End If
までと
If Intersect(Target, Columns("E")) Is Nothing Then Exit Sub '※変更部分
から
.Cells(re + 1, cp) = c.Offset(, -3).Value + c.Offset(, -2).Value
End With
End If
End Sub までを縦に繋ぎ「美装」と入力のあるコードの部分を「交換」に変更しただけなのですが結果は「実行エラー1004」がでました。
デバッグで確認すると
Application.Undo '変更前に戻す
この部分で止まってました。
縦繋ぎした
If Intersect(Target, Columns("E")) Is Nothing Then Exit Sub '※変更部分
〜〜〜〜
この部分にカーソルをおくとTargetに入っていたのは「美装」でした。
私が理解できていないだけなのですがご教授いただいたコードの初めから最後までループして指定している文字列「美装」の位置を検出していると思ったのですが間違っていますでしょうか？
でも間違っているから縦繋ぎした
If Intersect(Target, Columns("E")) Is Nothing Then Exit Sub '※変更部分
〜〜〜〜
この部分に「美装」が入っているのですよね（汗）
非常に難しいです。
仮に同じシートモジュールないで「美装」と「交換」を別に検索することは可能なのですか？
またまた手間な質問をすみません。
（ちぃさん） 2015/03/08(日) 02:07
まず、
・美装の時はこんな処理、交換の時は、また別のこんな処理
なのか
・美装、あるいは交換の時はこんな処理
なのかによってコードの構成は異なります。
そういう仕様とは別に、エラーに関しては、たんに変更したコードの構成に間違いがあったということです。 全コードを、そのままコピペでアップしてください。
それはそれとして、（上記で聞いている交換の場合の扱いにもよりますが）考え方をかえると、 コードが、少しシンプルになるかもしれません、 (UnDo を使わなくてもいいかも）
いずれにしても、上記質問の返事とコードアップ、お待ちします。
（β） 2015/03/08(日) 05:22
ちょっとアプローチを変えましょう。
まず、（おそらくですが）以下のシンプルな構え（UnDoをやめ）で、問題はないと思いますので これをベースにしましょう。
で、これに対し、交換の時は何をするのか、↑で聞いていることに回答願います。 その回答にそって、コードを改訂しましょう。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim re As Long '最終行
Dim cp As Long '転記列
Dim tr As Long '変更セル行番号
Dim s As Long '開始行
Dim c As Range
'E列の変更でなかったら処理しない
If Intersect(Target, Columns("E")) Is Nothing Then Exit Sub
'変更になったセル領域の最初が6行目未満なら処理しない
If Target(1).Row < 6 Then Exit Sub
Application.EnableEvents = False '今回のケースではイベント連鎖があっても不具合は発生しないけど念のため
'シートの最後の美装を検索
Set c = Range("E6", Range("E" & Rows.Count).End(xlUp)) _
.Find(After:=Range("E6"), What:="美装", LookAt:=xlWhole, SearchDirection:=xlPrevious)
If c Is Nothing Then '美装がない場合
'F2,H2が空白ではなかったら空白にするかどうかを聞く
If Len(Range("F2").Value) > 0 Or Len(Range("H2").Value) > 0 Then
If MsgBox("日時を空白にしますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
Range("F2,H2").ClearContents
End If
End If
Else '美装があった場合
'F2,H2が該当美装の日時でなかったら転記するかどうかを聞く
'Value2 は日付、時刻のシリアル値
If Range("F2").Value2 <> c.Offset(, -3).Value2 Or Range("H2").Value2 <> c.Offset(, -2).Value2 Then
If MsgBox("日時を転記しますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
Range("F2").Value = c.Offset(, -3).Value '美装日
Range("H2").Value = c.Offset(, -2).Value '美装時間
'Sheet2への書き込み
With Sheets("Sheet2")
s = 22
cp = 2
re = .Cells(30, cp).End(xlUp).Row
If re < s Then re = s + 3
'当該美装の日時
.Cells(re + 1, cp) = c.Offset(, -3).Value + c.Offset(, -2).Value
End With
End If
End If
End If
Application.EnableEvents = True
End Sub
（β） 2015/03/08(日) 08:59
書き込んだつもりが書き込めてなかったです（照）
すみません。
＞いずれにしても、上記質問の返事とコードアップ、お待ちします。
遅くなりましたが
Private Sub Worksheet_Change(ByVal Target As Range)
Dim re As Long '最終行
Dim cp As Long '転記列
Dim tr As Long '変更セル行番号
Dim s As Long '開始行
Dim rc2 As VbMsgBoxResult
Dim c As Range
Dim sv As Variant
If Intersect(Target, Columns("E")) Is Nothing Then Exit Sub '※変更部分
'変更になったセル領域の最初が6行目未満なら処理しない
If Target(1).Row < 6 Then Exit Sub '※追加部分
Application.EnableEvents = False '書き込みによるイベント発生を抑止
Application.Undo '変更前に戻す
sv = Target(1).Value '変更前のセルの値
Application.Undo '変更後に戻す
Application.EnableEvents = True 'イベント発生再開
'美装入力あるいは美装入力の変更以外は処理しない
If Target(1).Value <> "美装" And sv <> "美装" Then Exit Sub
rc2 = MsgBox("日時を転記しますか？", vbYesNo + vbQuestion, "確認")
If rc2 = vbNo Then
MsgBox "処理を中断します"
Exit Sub
Else
MsgBox "処理します"
Application.EnableEvents = False '書き込みによるイベント発生を抑止
Set c = Range("E6", Range("E" & Rows.Count).End(xlUp)) _
.Find(What:="美装", LookAt:=xlWhole, SearchDirection:=xlPrevious)
If c Is Nothing Then
'美装がない場合
Range("F2,H2").ClearContents '美装の日と時間欄をクリア
Else
Range("F2").Value = c.Offset(, -3).Value '美装日
Range("H2").Value = c.Offset(, -2).Value '美装時間
End If
Application.EnableEvents = True 'イベント発生再開
If c Is Nothing Then Exit Sub
'Sheet2への書き込み
With Sheets("Sheet2")
s = 22
cp = 2
re = .Cells(30, cp).End(xlUp).Row
If re < s Then re = s + 3
'当該美装の日時
.Cells(re + 1, cp) = c.Offset(, -3).Value + c.Offset(, -2).Value
End With
End If
'=============================追加分==================================
If Intersect(Target, Columns("E")) Is Nothing Then Exit Sub '※変更部分
'変更になったセル領域の最初が6行目未満なら処理しない
If Target(1).Row < 6 Then Exit Sub '※追加部分
Application.EnableEvents = False '書き込みによるイベント発生を抑止
Application.Undo '変更前に戻す
sv = Target(1).Value '変更前のセルの値
Application.Undo '変更後に戻す
Application.EnableEvents = True 'イベント発生再開
'美装入力あるいは美装入力の変更以外は処理しない
If Target(1).Value <> "交換" And sv <> "交換" Then Exit Sub
'~~~~~~ '~~~~~~
'↑変更部分 ↑変更部分
rc2 = MsgBox("日時を転記しますか？", vbYesNo + vbQuestion, "確認")
If rc2 = vbNo Then
MsgBox "処理を中断します"
Exit Sub
Else
MsgBox "処理します"
Application.EnableEvents = False '書き込みによるイベント発生を抑止
Set c = Range("E6", Range("E" & Rows.Count).End(xlUp)) _
.Find(What:="交換", LookAt:=xlWhole, SearchDirection:=xlPrevious)
'~~~~~
'↑変更部分
If c Is Nothing Then
'美装がない場合
Range("F3,H3").ClearContents '美装の日と時間欄をクリア
Else
Range("F3").Value = c.Offset(, -3).Value '美装日
Range("H3").Value = c.Offset(, -2).Value '美装時間
End If
Application.EnableEvents = True 'イベント発生再開
If c Is Nothing Then Exit Sub
'Sheet2への書き込み
With Sheets("Sheet2")
s = 22
cp = 2
re = .Cells(40, cp).End(xlUp).Row
If re < s Then re = s + 3
'当該美装の日時
.Cells(re + 1, cp) = c.Offset(, -3).Value + c.Offset(, -2).Value
End With
End If
End Sub
このような感じです。
追加部分は「美装」を「交換」に変更しご教示いただいコードを縦繫ぎしただけです。
処理内容は「美装」のときも「交換」の時も同じで違いがあるのは転記位置だけです。
どうど宜しくお願い致します。
（ちぃさん） 2015/03/08(日) 09:37
新たにアップしていただいコードで複数の指定文字列の設定を想定して追加しました。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim re As Long '最終行
Dim cp As Long '転記列
Dim tr As Long '変更セル行番号
Dim s As Long '開始行
Dim c As Range
'E列の変更でなかったら処理しない
If Intersect(Target, Columns("E")) Is Nothing Then Exit Sub
'変更になったセル領域の最初が6行目未満なら処理しない
If Target(1).Row < 6 Then Exit Sub
'シートの最後の美装を検索
Set c = Range("E6", Range("E" & Rows.Count).End(xlUp)) _
.Find(After:=Range("E6"), What:="美装", LookAt:=xlWhole, SearchDirection:=xlPrevious)
If c Is Nothing Then '美装がない場合
'F2,H2が空白ではなかったら空白にするかどうかを聞く
If Len(Range("F2").Value) > 0 Or Len(Range("H2").Value) > 0 Then
If MsgBox("日時を空白にしますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
Range("F2,H2").ClearContents
End If
End If
Else '美装があった場合
'F2,H2が該当美装の日時でなかったら転記するかどうかを聞く
'Value2 は日付、時刻のシリアル値
If Range("F2").Value2 <> c.Offset(, -3).Value2 Or Range("H2").Value2 <> c.Offset(, -2).Value2 Then
If MsgBox("日時を転記しますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
Range("F2").Value = c.Offset(, -3).Value '美装日
Range("H2").Value = c.Offset(, -2).Value '美装時間
'Sheet2への書き込み
With Sheets("Sheet2")
s = 22
cp = 2
re = .Cells(30, cp).End(xlUp).Row
If re < s Then re = s + 3
'当該美装の日時
.Cells(re + 1, cp) = c.Offset(, -3).Value + c.Offset(, -2).Value
End With
End If
End If
End If
'======================追加========================
If Intersect(Target, Columns("E")) Is Nothing Then Exit Sub
'変更になったセル領域の最初が6行目未満なら処理しない
If Target(1).Row < 6 Then Exit Sub
'シートの最後の美装を検索
Set c = Range("E6", Range("E" & Rows.Count).End(xlUp)) _
.Find(After:=Range("E6"), What:="交換", LookAt:=xlWhole, SearchDirection:=xlPrevious)
'~~~~~~
'変更部分
If c Is Nothing Then '美装がない場合
'F2,H2が空白ではなかったら空白にするかどうかを聞く
If Len(Range("F2").Value) > 0 Or Len(Range("H2").Value) > 0 Then
If MsgBox("日時を空白にしますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
Range("F2,H2").ClearContents
End If
End If
Else '美装があった場合
'F2,H2が該当美装の日時でなかったら転記するかどうかを聞く
'Value2 は日付、時刻のシリアル値
If Range("F2").Value2 <> c.Offset(, -3).Value2 Or Range("H2").Value2 <> c.Offset(, -2).Value2 Then
If MsgBox("日時を転記しますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
Range("F3").Value = c.Offset(, -3).Value '美装日
'~~~~~
'変更部分
Range("H3").Value = c.Offset(, -2).Value
'~~~~~~
'変更部分
'美装時間
'Sheet2への書き込み
With Sheets("Sheet2")
s = 22
cp = 2
re = .Cells(30, cp).End(xlUp).Row
If re < s Then re = s + 3
'当該美装の日時
.Cells(re + 1, cp) = c.Offset(, -3).Value + c.Offset(, -2).Value
End With
End If
End If
End If
'======================追加2========================
If Intersect(Target, Columns("E")) Is Nothing Then Exit Sub
'変更になったセル領域の最初が6行目未満なら処理しない
If Target(1).Row < 6 Then Exit Sub
'シートの最後の美装を検索
Set c = Range("E6", Range("E" & Rows.Count).End(xlUp)) _
.Find(After:=Range("E6"), What:="その他", LookAt:=xlWhole, SearchDirection:=xlPrevious)
'~~~~~~
'変更部分
If c Is Nothing Then '美装がない場合
'F2,H2が空白ではなかったら空白にするかどうかを聞く
If Len(Range("F2").Value) > 0 Or Len(Range("H2").Value) > 0 Then
If MsgBox("日時を空白にしますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
Range("F2,H2").ClearContents
End If
End If
Else '美装があった場合
'F2,H2が該当美装の日時でなかったら転記するかどうかを聞く
'Value2 は日付、時刻のシリアル値
If Range("F2").Value2 <> c.Offset(, -3).Value2 Or Range("H2").Value2 <> c.Offset(, -2).Value2 Then
If MsgBox("日時を転記しますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
Range("F4").Value = c.Offset(, -3).Value '美装日
'~~~~~~
'変更部分
Range("H4").Value = c.Offset(, -2).Value
'~~~~~~~
'変更部分
'美装時間
'Sheet2への書き込み
With Sheets("Sheet2")
s = 22
cp = 2
re = .Cells(30, cp).End(xlUp).Row
If re < s Then re = s + 3
'当該美装の日時
.Cells(re + 1, cp) = c.Offset(, -3).Value + c.Offset(, -2).Value
End With
End If
End If
End If
End Sub
追加する前は問題なく処理されていたのですが
「交換」「その他」
を追加すると「美装」の文字列を処理すると転記後に「美装」の転記した日付と時間が消去され、
次に「交換」の文字列を処理するとまた「美装」の転記した部分のセルが消去され、
次に「その他」の文字列を処理すると全ての処理した時間が転記されます。
「その他」の文字列がE列に存在していれば3つの文字列の処理が正常に動作します。
この転記場所は
「美装」の場合⇒ Range("F2").Value = c.Offset(, -3).Value '美装日
Range("H2").Value = c.Offset(, -2).Value '美装時間
「交換」の場合⇒Range("F3").Value = c.Offset(, -3).Value '美装日
'~~~~~
'変更部分
Range("H3").Value = c.Offset(, -2).Value
'~~~~~~
'変更部分
「その他」の場合⇒Range("F4").Value = c.Offset(, -3).Value '美装日
'~~~~~~
'変更部分
Range("H4").Value = c.Offset(, -2).Value
'~~~~~~~
'変更部分
のことです。
どの部分に訂正が必要でしょうか？
度々申し訳ありません。
どうぞ宜しくお願い致します。
（ちぃさん） 2015/03/08(日) 10:03
私が追加した部分に誤りがありました。
追加しても問題なく動作しました。
動作内容は素晴らしいです。
コードを1つづつ見ていきわからない部分はまた質問にきたいと思っております。
ありがとうございました。
（ちぃさん） 2015/03/08(日) 10:46
まずは、自助努力で、とりあえずうまくいったことは素晴らしい。 追加で課題が出れば、質問してくれたら、お手伝いするね。
ただ、美装か、交換のいずれかを処理するとして、そちらで付け加えた形は、コードとしては いかにも、もったいないというか、一度の入力で 美装 かつ 交換 ということはないので ２つ 縦にずらずらかくのではなく、１つで、まとめて書けますよ。
もう、見ないかもしれないけど、そのまとめたコード、参考として、後ほどアップしておきます。
（β） 2015/03/08(日) 11:02
まとめたコードをアプしておきますね。 なお、Sheet2には、それぞれ、どのように記載するのかが不明なので、美装、交換、その他 すべて 同じ場所に、ごっちゃに書いています。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim re As Long '最終行
Dim cp As Long '転記列
Dim tr As Long '変更セル行番号
Dim s As Long '開始行
Dim c As Range
Dim txt As Variant '検索用文字列
Dim myID As Long
Dim myTxt As Variant
Dim cellF As Range
Dim cellH As Range
'検索文字配列生成
myTxt = Array("美装", "交換", "その他")
'E列の変更でなかったら処理しない
If Intersect(Target, Columns("E")) Is Nothing Then Exit Sub
'変更になったセル領域の最初が6行目未満なら処理しない
If Target(1).Row < 6 Then Exit Sub
Application.EnableEvents = False '今回のケースではイベント連鎖があっても不具合は発生しないけど念のため
'シートの最後の美装、交換、その他を検索
For myID = 0 To UBound(myTxt)
txt = myTxt(myID) '検索文字列。Arrayで生成した配列は要素番号 0 から始まる
Set cellF = Range("F2").Offset(myID) 'この文字列に対応するF列のセル
Set cellH = Range("H2").Offset(myID) 'この文字列に対応するH列のセル
Set c = Range("E6", Range("E" & Rows.Count).End(xlUp)) _
.Find(What:=txt, LookAt:=xlWhole, SearchDirection:=xlPrevious)
If c Is Nothing Then '検索語句がない場合
'F,Hが空白ではなかったら空白にするかどうかを聞く
If Len(cellF.Value) > 0 Or Len(cellH.Value) > 0 Then
If MsgBox(txt & "の日時を空白にしますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
Range(cellF, cellH).ClearContents
End If
End If
Else '検索語句があった場合
'F,Hが該当検索語句の日時でなかったら転記するかどうかを聞く
'Value2 は日付、時刻のシリアル値
If cellF.Value2 <> c.Offset(, -3).Value2 Or cellH.Value2 <> c.Offset(, -2).Value2 Then
If MsgBox(txt & "の日時を転記しますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
cellF.Value = c.Offset(, -3).Value '美装等の日
cellH.Value = c.Offset(, -2).Value '美装等の時間
'Sheet2への書き込み
With Sheets("Sheet2")
s = 22
cp = 2
re = .Cells(30, cp).End(xlUp).Row
If re < s Then re = s + 3
'当該美装等の日時
.Cells(re + 1, cp) = c.Offset(, -3).Value + c.Offset(, -2).Value
End With
End If
End If
End If
Next
Application.EnableEvents = True
End Sub
（β） 2015/03/08(日) 11:35
＞まずは、自助努力で、とりあえずうまくいったことは素晴らしい。
アップして頂いたコードが素晴らしかったのです。
＞まとめたコードをアプしておきますね。
ありがとうございます。
なるほど。
Array関数を使うのですね。
最初のコードがまだ整理できていないのでいま手をつけると頭の中がグチャグチャになりそうです。
最初のが整理できてから見ていきます。
沢山ありがとうございます。
（ちぃさん） 2015/03/08(日) 12:36
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.