[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『追加質問』（ちぃさん）
お世話になります。
[[20150306215405]]
コチラでの追加質問になります。
ご教授いただいたコードの一部をCellsからRangeに変更したい部分がありまして質問に参りました。
宜しくお願い致します。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim re As Long '最終行
Dim cp As Long '転記列
Dim tr As Long '変更セル行番号
Dim s 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
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")
Set s = Range("B30").End(xlUp)
If s.Row < 25 Then
'当該美装の日時
.Range("B26") = c.Offset(, -3).Value + c.Offset(, -2).Value
End With
End If
End If
End If
コチラの
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
この部分を
With Sheets("Sheet2")
Set s = Range("B30").End(xlUp)
If s.Row < 25 Then
'当該美装の日時
.Range("B26") = c.Offset(, -3).Value + c.Offset(, -2).Value
End With
このように変更しようとしているのですがエラーがでます。
「End With に対するWithがありません」
何がダメなのでしょうか。
宜しくお願いいたします。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
If s.Row < 25 Then に対する End if がありません。
（マナ） 2015/03/08(日) 17:43
いけました。
動作確認してたら転記先が上書きされてることに今気づきました。
何度か同じような質問をしたことがあるのですが理解できてないみたいで解決できません。
With Sheets("Sheet2")
Set s = Range("B30").End(xlUp)
If s.Row < 25 Then
Set s = Range("B26")
'当該美装の日時
.Range("B" & s.Row) = c.Offset(, -3).Value + c.Offset(, -2).Value
End If
End With
何が足りてないでしょうか（汗）
すみません。
宜しくお願い致します。
（ちぃさん） 2015/03/08(日) 18:42
＞CellsからRangeに変更したい
必要最小限の修正だと、こうでは？ s = 22 cp = "B" re = .Range(cp & 30).End(xlUp).Row If re < s Then re = s + 3 '当該美装の日時 .Range(cp & re + 1) = c.Offset(, -3).Value + c.Offset(, -2).Value （マナ） 2015/03/08(日) 19:40
＞何が足りてないでしょうか（汗）
書き込み位置をずらす必要があります。今のを修正すると、こうでしょうか
Set s = Range("B30").End(xlUp)
If s.Row < 22 Then Set s = s.Offset(3)
'当該美装の日時
s.Offset(1).Value = c.Offset(, -3).Value + c.Offset(, -2).Value
（マナ） 2015/03/08(日) 20:03
＞書き込み位置をずらす必要があります。今のを修正すると、こうでしょうか
転記がされないようです。
すみません。
s.Offset(3) はどこからでてきたのでしょうか?(汗)
（ちぃさん） 2015/03/08(日) 20:19
失礼。↑のは、ピリオド（.）も足りませんでした。
Set s = .Range("B30").End(xlUp
（マナ） 2015/03/08(日) 20:24
＞s.Offset(3) はどこからでてきたのでしょうか?(汗)
元のコードで言えば、re = s + 3 （マナ） 2015/03/08(日) 20:28
Offsetプロパティの事すっかりわしれてました。
すみません。
何故かB2から転記がはじまるのですが。。。。。（汗）
If s.Row < 22 Then
があるのに何故でしょうか???
（ちぃさん） 2015/03/08(日) 20:55
Set s = .Range("B30").End(xlUp)
If s.Row < 22 Then Set s = .Range("B25")
'当該美装の日時
s.Offset(1).Value = c.Offset(, -3).Value + c.Offset(, -2).Value
（マナ） 2015/03/08(日) 21:07
With Sheets("Sheet2")
Set s = .Range("B30").End(xlUp)
If s.Row < 22 Then Set s = s.Range("B23").Offset(0, -1)
'当該美装の日時
s.Offset(1).Value = c.Offset(, -3).Value + c.Offset(, -2).Value
End With
これでいけました。
ありがとうございました。
（ちぃさん） 2015/03/08(日) 21:18
＞Set s = s.Range("B23").Offset(0, -1)
意味が理解できていますか。たぶん間違っていますよ。
（マナ） 2015/03/08(日) 21:25
元のコードは、 １）B列の最終行を求める ２）最終行＜２２なら、最終行＝２５とする ３）最終行の一つ下に書き込む
これが、 ２）最終行＜２２なら、最終行＝最終行＋２２とする になっていませんか？
＞Set s = s.Range("B23").Offset(0, -1)
は、
Set s = s.Offset(22)
と同じ意味ですが、それでよいですか。
（マナ） 2015/03/08(日) 21:44
あれ（汗）間違っているのですかね（汗）
もう一度確認してみます。（汗）
（ちぃさん） 2015/03/08(日) 21:58
確認してみたのですが
If s.Row < 22 Then Set s = .Range("B25")
これだけだと C26 に転記されるのですが。。。。。（汗）
なぜC列になるのかが不思議なのですが（汗）
If s.Row < 22 Then Set s = s.Range("B25")
になっていませんか。
（マナ） 2015/03/08(日) 22:25
＞s.Range("B25")
になってました。（照）
.Range("B25")
これで正しい場所に転記されました。
でもどうしてなのですか?
時間があれば教えていただけないでしょうか？
（ちぃさん） 2015/03/08(日) 22:33
Sub test()
Dim s As Range
Set s = Range("B1")
MsgBox s.Address(0, 0)
MsgBox Range("B1").Address(0, 0)
MsgBox Range("B25").Address(0, 0)
MsgBox Range("B1").Range("B25").Address(0, 0) '★
MsgBox s.Range("B25").Address(0, 0) '★
End Sub
s.Range("B25").Address(0, 0)
は、sを基点として、相対的な位置になります。
（マナ） 2015/03/08(日) 23:08
勉強になりました。
（ちぃさん） 2015/03/08(日) 23:21
私はここをよく参考にしています。 今回の件は、相対指定の部分ですが、 他の部分も、とても勉強になります。
http://hp.vector.co.jp/authors/VA016119/range1.html
全部を一度にでなくても、 必要な部分を、必要なときに理解できるとよいと思います。
（マナ） 2015/03/08(日) 23:25
参考にします。
（ちぃさん） 2015/03/08(日) 23:38
もう見ないかも？
マナさんにフォローいただいて、壁を１つクリアできてよかったですね。 もともと、Sheet2への転記は、その要件が不明だったので、一連のトピでは、オリジナルコードのまま、 セットする日時を処理時点の日時ではなく、当該データの日時にかえてもらっただけですが、 今後、美装、交換、その他 を扱う場合（以前コメントしたけど）、これらが同じ場所にごっちゃに混ざっていて いいのかな？ と思ってます。
いずれ、複数文字列バージョンで、新しいトピをたてることもあるかもしれないね。 その際には、この Sheet2 のセット要件も説明したほうがいいかも。
（β） 2015/03/09(月) 09:02
＞もう見ないかも？
いま手元にエクセルがないので説明が難しいのでエクセルがある時に投稿します。
ありがとうございます。
（ちぃさん） 2015/03/09(月) 14:20
すみません。
説明の内容を理解できていないのだともうのですが
[[20150306215405]]
にある
＞来なら、複数セルを意識して、Targetの中のセルを１つずつ取り出して処理しなければいけないんですが
＞まぁ、そこは手を抜いていて、仮に複数セルだったとしても、その中の先頭のセルしか相手にしていません。
＞それは、困る。すべて相手にしてほしい ということであれば、対応しますが？）
これって指定した文字列「美装」が連続しているいても対応できるということなのでしょうか?
というのも今気づいたのですが現在、セル1つを15分としてます。
「美装」が15分で完了する場合もあれば45分かかる場合もあり、45分必要となった場合にセルを3つ「美装」と入力すれば3回転記のメッセージがでます。
3回でても転記の必要のない時は「いいえ」でいいのですが（汗）
もしかしたら連続していた場合はメッセージを無視されることができるのかな？って思ってしまいました。
連続というのは
Sheet1
__A__ ____B____ ____C____ __D__ ____E____ ____F____ ____G____ ____H____ 1 日時 合計 美装時間 2 1 1 11:30 3 4 5 6 1日 9:00 美装 7 1日 9:15 美装 8 1日 9:30 美装
こんな感じの事をいってます。
でも
Sheet1
__A__ ____B____ ____C____ __D__ ____E____ ____F____ ____G____ ____H____ 1 日時 合計 美装時間 2 1 1 11:30 3 4 5 6 1日 9:00 美装 7 1日 9:15 美装 8 1日 9:30 美装 9 1日 9:45 10 1日 10:00 美装 11 1日 10:15 美装
こんな感じに一つ飛びの場合があったりする場合があれば難しい気もします。
全く違うように解釈していればすみません。
Sheet1
__A__ ____B____ ____C____ __D__ ____E____ ____F____ ____G____ ____H____ _____I_____ 1 日時 合計 美装時間 繰越し 2 1 1 11:30 1000 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 . . . . . .
使用しているシートは1ヵ月で区切るのですが毎月都合よく月末に「美装」できるときばかりではなく繰り越してしまう場合があります。
そのくりこしたものを無視できないので
G2=SUMPRODUCT((C6:C3000>=H2)*(E6:E3000="ｴｸｾﾙ"),G6:G3000)+I2
として前の月のものをプラスしているのですが月が替わり「美装」すると繰越し分はリセットします。
現在、
Private Sub Worksheet_Change(ByVal Target As Range)
Dim re As Long '最終行
Dim cp As Long '転記列
Dim tr As Long '変更セル行番号
Dim s 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(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
'------------Sheet2への書き込み----------------
With Sheets("Sheet2") '転記先Sheet
Set s = .Range("D30").End(xlUp) '転記最下行設定
If s.Row < 25 Then Set s = .Range("D26") '転記始まりセル※指定セル以降より
s.Offset(1, 1).Value = Sheets("Sheet1").Range("I2") '転記元
Sheets("Sheet1").Range("I2") = ""
End With
'-----------------------------------------------
Range("F2").Value = c.Offset(, -3).Value '美装日
Range("H2").Value = c.Offset(, -2).Value '美装時間
'当該美装の日時
s.Offset(1).Value = c.Offset(, -3).Value + c.Offset(, -2).Value
End If
End If
End If
End Su
としてるのですが
'------------Sheet2への書き込み----------------
With Sheets("Sheet2") '転記先Sheet
Set s = .Range("D30").End(xlUp) '転記最下行設定
If s.Row < 25 Then Set s = .Range("D26") '転記始まりセル※指定セル以降より
s.Offset(1, 1).Value = Sheets("Sheet1").Range("I2") '転記元
Sheets("Sheet1").Range("I2") = ""
End With
'-----------------------------------------------
この部分と
Range("F2").Value = c.Offset(, -3).Value '美装日
Range("H2").Value = c.Offset(, -2).Value '美装時間
の場所を入れ替えています。
現時点では不具合は発生してないのですが今後トラブルの原因になりますでしょうか？
夜遅くに手間な質問をすみません。
（ちぃさん） 2015/03/10(火) 01:08
とりあえず最初の質問に関して。
「手を抜いている」というのは、そういう意味ではなく、本来なら「入力されたものだけ」をチェックして それが、美装関連なら処理するのが適切ですが、現在のコードでは、とにかく Ｅ列に変更があれば処理するという部分をさしています。 ただ、処理が不要であればロジックの中で処理せず終了させていますので、１００点ではないけど、９５点ぐらいかな？
本題です。
現在の構えはシートイベント処理ですね。 マクロの実行タイプとして、何か所か入力をしたあと、さぁ、今から実行だと、実行指示（マクロボタンなんかで）を行うものがありますね。 一方、イベント処理は、「何かが行われたら」「自動的に動かす」というものです。 本件処理には、このイベント処理が向いていると思います。
美装といれた、だけど、マクロ処理をするのを忘れた・・なんてことがないような構えですから。
でも、「何かが行われたら」「必ず実行されてしまう」という宿命をもっています。
提示の例で、６行目に美装が入力された。この時、マクロは、この入力者が、そのあと、続けて７行目にも美装、８行目にも美装と そう入力するか、この６行目の入力のみで、その日がおわるのか、判断できないですね。 ですから、とりあえず、６行目に入力があった時点で処理せざるを得ません。 で、７行目に入力があった場合も処理する・・・・宿命なんです。
こんなことはできます。
１．処理構成の変更
イベント処理を行わず、操作者が要求した時だけマクロ実行。 で、実行忘れを防ぐために、ブックを保存して閉じるさいに、念のため必ず自動実行。
２．入力順の工夫
コードでは処理した時点で、「最後の美装」の日時が F2,H2 と同じかどうかチェックし、同じであれば 処理を終了しています。 ですから、「一日分の美装をまとめて」入力する場合、「一番最後の美装」を、まず入力する。 この時点で処理が行われ、F2,H2の値が、最後の美装のものになる。 そのあと、それより上のほうの美装を（何か所でも）入力していく。 処理は走りますが、「すでに最後の美装の日時とF2,H2が同じなのでメッセージは出ずに終了」 こうなります。
（β） 2015/03/10(火) 08:30
何回かコメントしている通り、Sheet2の扱いについては、
・そのレイアウトがどうなっているのか？
・それを、どのように使用しているのか？
こちらでは見えないので（わからないので）適切な回答ができるかどうか？
とりあえず。
コードの順番をかえて影響ないかということですが、見た限りでは影響はないと思います。
ただ、逆に、順番を入れ替える必要性もわかりません。
s.Offset(1).Value = c.Offset(, -3).Value + c.Offset(, -2).Value
これが、
Range("F2").Value = c.Offset(, -3).Value '美装日
Range("H2").Value = c.Offset(, -2).Value '美装時間
この前にあろうと、後にあろうと、結果は同じでは？
それより、気になること。
Set s = .Range("D30").End(xlUp) '転記最下行設定
If s.Row < 25 Then Set s = .Range("D26") '転記始まりセル※指定セル以降より
Sheet2の、上のほうのレイアウトがどうなっているのかわからないのですが、
とにかくＤ列のデータの最後をチェックする。
で、おそらく ２７行目からの記入にしたいのですかね？
なので D26 をベースにして Offset(1)
だけど、仮に s.Row が 25 だった場合、 s.Row < 25 じゃないですから 25 のまま。
なので、Offset(1) で 26行目に書き込まれます。いいのかな？
さらに、D30からチェックしているということは、記入行が D30 まで？
この部分の記入要領というか、記入規則を教えてもらえれば、書き込み行に関して
もう少し、わかりやすい判定もできるかもしれない。
それと、実際には影響はでないんですが、イベント連鎖の抑止コードは消しちゃったのかな？
（β） 2015/03/10(火) 09:29
＞７行目に入力があった場合も処理する・・・・宿命なんです。
なるほどです。
今のコードから「美装」が連続してても私がいうような処理ができるのかな？と思いながらの投稿でした。
理解しました。
ありがとうございます。
＞１．処理構成の変更
提案していただいた案も興味があるので想像してみました。
でも今の処理がベストな気がします。
＞２．入力順の工夫
コチラで検討したいと思います。
＞何回かコメントしている通り、Sheet2の扱いについては、
＞・そのレイアウトがどうなっているのか？
＞・それを、どのように使用しているのか？
＞こちらでは見えないので（わからないので）適切な回答ができるかどうか？
Sheet2のレイアウトの変更が必要になりそうなので会社で相談しレイアウトがハッキリしてから改めて投稿致します。
＞ただ、逆に、順番を入れ替える必要性もわかりません。
Sheets("Sheet1").Range("I2") = ""
この部分の処理の影響で
Set s = .Range("D30").End(xlUp) '転記最下行設定
If s.Row < 25 Then Set s = .Range("D26") '転記始まりセル※指定セル以降より
s.Offset(1, 1).Value = Sheets("Sheet1").Range("I2") '転記元
この部分の処理の転記が思うように出来なかったので順番の入れ替えをしました。
私が勝手に追加した部分なので記述の仕方がマズイのかもしれないのですが(汗)
＞それと、実際には影響はでないんですが、イベント連鎖の抑止コードは消しちゃったのかな？
入れ替えをしていた時誤って入れ忘れてるみたいです。
すみません。
（ちぃさん） 2015/03/10(火) 11:23
Sheet2
__A__ _B_ _C_ ______D______ ______E______ ______F______ ______G______ ______H______ ______I______ 1 2 お客様名 納期 3 〜 9 その他日時 その他m数 10 11 依頼品目 原料Lot 12 依頼品目 原料Lot 〜 18 作業者 1部 2部 管理者 19 作業者 1部 2部 管理者 〜 25 美装日時 美装m数 交換日時 交換m数 26 27 28 29 30 ________________________________________________________________________________
このような感じです。
で、現在
Private Sub Worksheet_Change(ByVal Target As Range)
Dim re As Long '最終行
Dim cp As Long '転記列
Dim tr As Long '変更セル行番号
Dim s 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
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
'------------Sheet2への書き込み----------------
With Sheets("Sheet2") '転記先Sheet
Set s = .Range("D30").End(xlUp) '転記最下行設定
If s.Row < 25 Then Set s = .Range("D25") '転記始まりセル※指定セル以降より
s.Offset(1, 1).Value = Sheets("Sheet1").Range("I2") '転記元
Sheets("Sheet1").Range("I2") = ""
End With
'-----------------------------------------------
Range("F2").Value = c.Offset(, -3).Value '美装日
Range("H2").Value = c.Offset(, -2).Value '美装時間
'当該美装の日時
s.Offset(1).Value = c.Offset(, -3).Value + c.Offset(, -2).Value
End If
End If
End If
'===============================交換============================
'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("F3").Value) > 0 Or Len(Range("H3").Value) > 0 Then
If MsgBox("日時を空白にしますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
Range("F3,H3").ClearContents
End If
End If
Else '美装があった場合
'F2,H2が該当美装の日時でなかったら転記するかどうかを聞く
'Value2 は日付、時刻のシリアル値
If Range("F3").Value2 <> c.Offset(, -3).Value2 Or Range("H3").Value2 <> c.Offset(, -2).Value2 Then
If MsgBox("日時を転記しますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
'------------Sheet2への書き込み----------------
With Sheets("Sheet2") '転記先Sheet
Set s = .Range("F30").End(xlUp) '転記最下行設定
If s.Row < 25 Then Set s = .Range("F25") '転記始まりセル※指定セル以降より
s.Offset(1, 1).Value = Sheets("Sheet1").Range("I3") '転記元
Sheets("Sheet1").Range("I3") = ""
End With
'-----------------------------------------------
Range("F3").Value = c.Offset(, -3).Value '美装日
Range("H3").Value = c.Offset(, -2).Value '美装時間
'当該美装の日時
s.Offset(1).Value = c.Offset(, -3).Value + c.Offset(, -2).Value
End If
End If
End If
'===========================その他==========================
'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("F4").Value) > 0 Or Len(Range("H4").Value) > 0 Then
If MsgBox("日時を空白にしますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
Range("F4,H4").ClearContents
End If
End If
Else '美装があった場合
'F2,H2が該当美装の日時でなかったら転記するかどうかを聞く
'Value2 は日付、時刻のシリアル値
If Range("F4").Value2 <> c.Offset(, -3).Value2 Or Range("H4").Value2 <> c.Offset(, -2).Value2 Then
If MsgBox("日時を転記しますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
'------------Sheet2への書き込み----------------
With Sheets("Sheet2") '転記先Sheet
Set s = .Range("H30").End(xlUp) '転記最下行設定
If s.Row < 9 Then Set s = .Range("H9") '転記始まりセル※指定セル以降より
s.Offset(1, 1).Value = Sheets("Sheet1").Range("I4") '転記元
Sheets("Sheet1").Range("I4") = ""
End With
'-----------------------------------------------
Range("F4").Value = c.Offset(, -3).Value '美装日
Range("H4").Value = c.Offset(, -2).Value '美装時間
'当該美装の日時
s.Offset(1).Value = c.Offset(, -3).Value + c.Offset(, -2).Value
End If
End If
End If
Application.EnableEvents = True
End Sub
このような感じです。
[[20150306215405]]
こちらの最後にありました
＞まとめたコードをアプしておきますね。
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 まとめて頂いているコードでもSheet2への転記は可能なのでしょうか？
美装日時⇒D26:D30 美装m数⇒E26:E30
交換日時⇒F26:F30 交換m数⇒G26:G30
その他日時⇒H10:30 その他m数⇒I10:I30
（ちぃさん） 2015/03/10(火) 21:30
まとめたほうがいいですね。
ただ、アップした時点から、現在の(ちぃさん)のコード要件がかわっているかもしれないので、 ２つを見比べながら、まとめたバージョンで Sheet2 もメンテするものを書いてみます。
少し時間ください。
（β） 2015/03/10(火) 21:49
何度も申し訳ございません。
宜しくお願いいたします。
（ちぃさん） 2015/03/11(水) 00:02
追伸です。
もしかしてなのですが
チェンジイベントはステップインができない?とかなのでしょうか???（汗）
なぜか確認できませんので、そうなのかなと思いまして。（汗）
>チェンジイベントはステップインができない?とかなのでしょうか???（汗）
Chageイベントにかかわらず、イベント処理のほとんどはステップインできませんね。 これができるのは、Workbookイベントの Open 等、ごくわずかです。
たとえばChageイベントは
Private Sub Worksheet_Change(ByVal Target As Range)
つまり、イベントが発生した時の、変更のあったセル情報が Target として格納されて処理が始まります。 ステップインでは、その Target 情報が与えられないので、処理が不可能なんです。
状況をステップごとに確認していきたい場合は、たとえば
If Intersect(Target, Columns("E")) Is Nothing Then Exit Sub
ここに【ブレークポイント】を設定しておいて、シート側で、どこかのセルに入力を行う。 イベントが発生して、このプロシジャに入ってくる。 で、ブレークポイントでとまる。
ここから、F8 をおしながら進めていくことができます。
（β） 2015/03/11(水) 04:47
勉強になります。
ありがとうございます。
（ちぃさん） 2015/03/11(水) 16:59
そちらの現行のコードと、まとめたコード（こちらにあるのが最新版）との突合せが終わりました。 基本的には、I列繰り越し項目とSheet2処理以外は祖語がなかったので、こちらの最新版に、それらを 加味したものを、コード書き上げ次第アップします。
前々から気になっていたんですが、Sheet2、たとえば美装でいうと、D26〜D30 に５つ格納されますね。 で、５つ格納されたら、次はどうしますか？ 上に戻って 26から上書きしていきますか？ それとも、最後の 30 を上書きしますか？ あるいは、いっぱいになっていたら、26〜30をクリアした上で、26から書いていきますか？
（β） 2015/03/11(水) 19:21
＞５つ格納されたら、次はどうしますか？
すみません。
考えてなかっです。(汗)
余裕をみて枠が5つあれば十分と判断してましたので。(汗)
でも記録された5つの記録はどれも必要なので上書きなどで消えてしまうのは都合が悪いです。
最悪、5つ目まで到達したとしてそれ以降は5つ目に上書きされるパターンで行きたいと思います。
どうぞ宜しくお願い致します。
（ちぃさん） 2015/03/11(水) 19:58
簡単な動作確認はしてありますが、要件誤解していたら指摘願います。 なお、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
Dim cellI As Range
Dim arrayS2 As Variant
Dim w As Variant
Dim x As Long
Dim area2 As Range
Dim set2 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 '今回のケースではイベント連鎖があっても不具合は発生しないけど念のため
'検索文字配列生成
myTxt = Array("美装", "交換", "その他")
'検索文字に相当するSheet2セット域
ReDim arrayS2(LBound(myTxt) To UBound(myTxt))
With Sheets("Sheet2")
x = LBound(arrayS2)
For Each w In Array(.Range("D26:D30"), .Range("F26:F30"), .Range("H10:H30"))
Set arrayS2(x) = w
x = x + 1
Next
End With
'シートの最後の美装、交換、その他を検索
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 cellI = Range("I2").Offset(myID) 'この文字列に対応するI列のセル
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
cellF.ClearContents
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への書き込み
Set area2 = arrayS2(myID)
If area2.Cells(area2.Count).Value <> "" Then 'すでに満杯
Set set2 = area2.Cells(area2.Count)
Else
Set set2 = area2.Cells(area2.Count).Offset(1).End(xlUp).Offset(1)
End If
'当該美装等の日時
set2.Value = c.Offset(, -3).Value + c.Offset(, -2).Value
set2.Offset(, 1).Value = cellI.Value
cellI.ClearContents
End If
End If
End If
Next
Application.EnableEvents = True
End Sub
（β） 2015/03/11(水) 22:00
↑
最初のほうの
'検索文字に相当するSheet2セット域
ReDim arrayS2(LBound(myTxt) To UBound(myTxt))
With Sheets("Sheet2")
x = LBound(arrayS2)
For Each w In Array(.Range("D26:D30"), .Range("F26:F30"), .Range("H10:H30"))
Set arrayS2(x) = w
x = x + 1
Next
End With
コードとしては、問題ないのですが、まわりくどいコードになってます（汗）
'検索文字に相当するSheet2セット域
With Sheets("Sheet2")
arrayS2 = Array(.Range("D26:D30"), .Range("F26:F30"), .Range("H10:H30"))
End With
これに置き換えてください。
それと・・・・・
Sheet2 の その他の領域が他より大きいので、あっ！ もしかして。 コードでは "美装"、"交換" そして "その他" という文字列が入った時に処理しています。
でも・・・・"その他" というのは "その他"という文字列ではなく、美装、交換 以外 ということでしたか？
もし、そうなら、そのように直しますので。
（β） 2015/03/11(水) 23:53
取り急ぎお礼まで申し上げます。
いま手元にエクセルがありませんので後で動作を見させていただます。
＞でも・・・・"その他" というのは "その他"という文字列ではなく、美装、交換 以外 ということでしたか？
今のままで多分大丈夫かと思います。
紛らわし言葉を指定の文字列にして申し訳ありません。
又、わからない部分(コード内容で)がありましたら質問させていただきたいです。
（ちぃさん） 2015/03/12(木) 00:27
問題ない動作でした。
ありがとうございます。
1ついいでしょうか。（汗）
今頃になって気づいたのですが。。。。。。（汗）
「美装」で例えると「美装」を入力すると
「美装日時を転記しますか？」
と問いかけがあります。「はい」であれば処理され「いいえ」であれば処理がとまります。
問いかけされた時に「いいえ」を選択し処理を拒否したのち「エクセル」を入力すると
「美装日時を転記しますか？」
と問いかけがあります。
これは
＞美装といれた、だけど、マクロ処理をするのを忘れた・・なんてことがないような構えですから。
という前提だからでしょうか？
もしかして「いいえ」を選択したのち次回「美装」を入力すれまでメッセージを無効にはできるのでしょうか？
今更になってこんな事を言い出し申し訳ありません。
可能でしたら教えて頂けないでしょうか。
どうぞ宜しくお願い致します。
もし可能でしたら、問いかけに対して否定しているので無効にできればと思います。
（ちぃさん） 2015/03/12(木) 13:05
おはようございます
通常の Changeイベントの処理は、「定められたところに」「さだめられた変更が起こった時に」実行するという構えです。 ところが、今回の構えは、何度かコメントしているように、「E列に何かが入力されたら」その入力が何であったかにかかわらず その時のシートの状況を調べ、最後の美装の日時が F2,H2 に書かれているか、最後の交換の日時が F3,H3 に書かれているか 最後のその他の日時が F4,H5 に書かれているか、それを調べて、そうなっていなかったら、それぞれについて 処理をするかどうかを聞いています。
なので、「いいえ」を選んでも、シートの状況はそのままなので、次に何かしらの E列入力で、やはり、メッセージがでます。
これを、E列に入力されたものが 美装、交換、その他 （あるいは、それらの語句から別の語句への変更） であった時のみ、その語句に関する処理だけを行うということはできます。 （手を抜いていると申し上げていた部分は、そこです）
そうしますか？
（β） 2015/03/13(金) 08:19
とりあえず、以下で試してみてください。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim txt As Variant '検索用文字列
Dim myID As Long
Dim myTxt As Variant
Dim cellF As Range
Dim cellH As Range
Dim cellI As Range
Dim arrayS2 As Variant
Dim w As Variant
Dim x As Long
Dim area2 As Range
Dim set2 As Range
Dim changeR As Range
Dim todoFlag As Variant
Dim z As Variant
'変更になったセル領域の最初が6行目未満なら処理しない
If Target(1).Row < 6 Then Exit Sub
'E列の変更でなかったら処理しない
Set changeR = Intersect(Target, Columns("E"))
If changeR Is Nothing Then Exit Sub
'検索文字配列生成
myTxt = Array("美装", "交換", "その他")
'検索文字に相当するSheet2セット域
With Sheets("Sheet2")
arrayS2 = Array(.Range("D26:D30"), .Range("F26:F30"), .Range("H10:H30"))
End With
'各検索文字についての処理要否配列
ReDim todoFlag(LBound(myTxt) To UBound(myTxt)) As Boolean
Application.EnableEvents = False '★必須
'入力された値をチェックし、処理必要な文字列かどうかを判定。
For x = 1 To 2 '変更前と変更後の状態をチェック
Application.Undo '変更後->変更前 あるいは 変更前->変更後
For Each c In changeR.Cells
z = Application.Match(c.Value, myTxt, 0)
If IsNumeric(z) Then todoFlag(z - 1) = True
Next
Next
'シートの最後の美装、交換、その他を検索
For myID = 0 To UBound(myTxt)
If todoFlag(myID) Then '当該文字列の入力または変更時のみ処理を行う。
txt = myTxt(myID) '検索文字列。Arrayで生成した配列は要素番号 0 から始まる
Set cellF = Range("F2").Offset(myID) 'この文字列に対応するF列のセル
Set cellH = Range("H2").Offset(myID) 'この文字列に対応するH列のセル
Set cellI = Range("I2").Offset(myID) 'この文字列に対応するI列のセル
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
cellF.ClearContents
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への書き込み
Set area2 = arrayS2(myID)
If area2.Cells(area2.Count).Value <> "" Then 'すでに満杯
Set set2 = area2.Cells(area2.Count)
Else
Set set2 = area2.Cells(area2.Count).Offset(1).End(xlUp).Offset(1)
End If
'当該美装等の日時
set2.Value = c.Offset(, -3).Value + c.Offset(, -2).Value
set2.Offset(, 1).Value = cellI.Value
cellI.ClearContents
End If
End If
End If
End If
Next
Application.EnableEvents = True '★必須
End Sub
（β） 2015/03/13(金) 13:52
遅くなり申し訳ありません。
何度も直して頂きありがとうございます。(感謝感謝)
今エクセルがないのでまだ動作を見れてないので動作をみてから投稿させてもらおうとおもってます。
私の為に貴重な時間を使って頂きありがとうございます。
（ちぃさん） 2015/03/13(金) 17:07
まったく問題なく希望したままの動作でした。
作っていただいたコードが難しく全く理解できておりませんので何か追加したくなった場合、変更したい場合の事を思うと。。。。。（汗）
時間が掛ると思いますが少しずつ理解していきたいと思います。
長くお付き合いいただき本当にありがとうござました。
（ちぃさん） 2015/03/14(土) 01:01
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.