『VBA 元データに上書きする』（許斐） [[20090907110536]] フォーム　E4　に該当した職員番号をのデータを シート貸出 シートサイズ に上書きする方法を教えてください。 転記のコードとほぼ同じと思い内容はいじらず。 多分 mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 を上書きする指令文にすれば何とかなると思い・・・・ mr = Range("E4").Resize(, 115).Value　変更してみましたが、無駄な足掻きでした。 Sub uwagaki() Dim mr As Long Dim i As Long, ii As Long, cn As Long Dim kk, WS As Worksheet Dim msg As String syokuinNo = Worksheets("フォーム").Range("E4").Value kk = Application.Match(Range("E4").Value, Worksheets("被服貸与").Range("A:A"), 0) If IsNumeric(kk) = 0 Then MsgBox "入力された職員番号のデータが見つかりません。" Exit Sub End If '服 With Worksheets("被服貸与").Range("A:A") mr = .Range("A:A").Resize(, 115).Value .Cells(mr, 1).Value = Range("E4").Value '職員番号 .Cells(mr, 2).Value = Range("B5").Value '氏名 .Cells(mr, 3).Value = Range("B4").Value 'ふりがな .Cells(mr, 4).Value = Range("E5").Value '生年月日 .Cells(mr, 6).Value = Range("H5").Value '採用年月日 .Cells(mr, 8).Value = Range("H4").Value '階級 .Cells(mr, 9).Value = Range("J4").Value '所属 cn = 9 '9行目〜の設定 For i = 7 To 18 '行番頭 i = 1 For ii = 2 To 4 '列番号 cn = cn + 1 .Cells(mr, cn).Value = Cells(i, ii).Value Next Next For i = 7 To 17 '行番号 i = 1 For ii = 6 To 8 '列番号 cn = cn + 1 .Cells(mr, cn).Value = Cells(i, ii).Value Next Next For i = 7 To 18 '行番号 i = 1 For ii = 10 To 12 '列番号 cn = cn + 1 .Cells(mr, cn).Value = Cells(i, ii).Value Next Next .Cells(mr, 115).Value = Range("F18").Value '備考 End With 'サイズ With Sheets("採寸表") mr = .Range("A:A").Resize(, 21).Value .Cells(mr, 1).Value = Range("E4").Value '職員番号 .Cells(mr, 2).Value = Range("B5").Value '氏名 .Cells(mr, 3).Value = Range("B4").Value 'ふりがな For i = 1 To 5 '頭,首,胸囲 .Cells(mr, i + 3).Value = Range("B" & i + 20).Value .Cells(mr, i + 8).Value = Range("D" & i + 20).Value Next For i = 1 To 4 'ｷｬｯﾌﾟ,シャツ,上着,ズボン .Cells(mr, i + 13).Value = Range("F" & i).Value .Cells(mr, i + 17).Value = Range("H" & i).Value Next End With End Sub ---- テキトウな事を言うと mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 mrには、データがある最終行+1 の値が入ります。 新規登録する際に入力する行が データがある最終行+1 の行だからです。 上書き時に入力する行は、被服貸与シートの場合 kk = Application.Match(Range("E4").Value, Worksheets("被服貸与").Range("A:A"), 0) これで見つかった位置じゃないですか？ (HANA) ---- HANA　さん できました。ありがとうございます。 一日悩んだ私はいったい（涙） （許斐） ---- 前のスレの「Sub どこにあるか()」で 　MsgBox kk & "行目にありました。" って書いたんですけどね。。。 さて、コードとしては　新規登録と変更は 転記すべき行番号の取得方法が変わってきます。 ですが、使う方としては「登録」という同じ作業です。 例えば If IsNumeric(kk) = 0 Then MsgBox "入力された職員番号のデータが見つかりません。" Exit Sub End If ここで、メッセージを出してExit Subするのではなく 　見つからなかったら、最終行+1 の行を転記先行の変数に入力。 　見つかったら、その値を転記先行の変数に入力。 　続いて、実際に 転記先行の変数 の行に転記。 と言う流れにしておけば、一つのコードに出来るのではないかと思います。 ＞With Worksheets("被服貸与") の中で行えば、 kk = Application.Match(Range("E4").Value, Worksheets("被服貸与").Range("A:A"), 0) この部分も省略出来ますね／~~~~~~~~~~~~~~~~~~~~~~ また、実は　削除の時もループして一つずつ見比べるのではなく kkの行を削除する事にしても良いんじゃないかと思います。 同じ事をする（コードが入力されている行を検索する）のに 別々の方法を使っているのが、どうかなぁ　と思ってみたり。。。 (HANA) ---- HANAさん 遅くまでありがとうございます。 > MsgBox kk & "行目にありました。" すみません。直します。f^ ^；； しかも掲載したコード不必要もの多々と。。。明日直します。 >　見つからなかったら、最終行+1 の行を転記先行の変数に入力。 >　見つかったら、その値を転記先行の変数に入力。 >　続いて、実際に 転記先行の変数 の行に転記。 変数を代入ですか？これは新たなマクロですね。 うー気になりますが、ムダが多いですが折角作りましたのでこのまま使用したいと思います。 登録と修正とボタン二個欲しいです。 許斐 ---- ＞すみません。直します。f^ ^；； ん？直すんじゃなくて 　「COUNTIFでは有無しか分からないけど 　　MATCHで求めると何行目に有るか分かるよ。」 　　↓ 　「新規登録以外では、その行を処理すれば良いからね。」 　を含めてコメントしていた ってだけなんですが。 ＞変数を代入ですか？これは新たなマクロですね。 登録マクロ・修正マクロ　と考えると 登録修正マクロ　と言う新たなマクロ と言えるかもしれませんが。。。 新規登録時は、転記先の行番号をmr に入れました。 実際は最大行+1 の番号が入っていますが この名前は、ＭaxＲow番号と言った感じです。 MATCH関数の戻り値（行番号）は、kk に入れました。 実際は、見つからなかった時にエラー値も入りますが。。。 この名前は、ＫensakuＫekka で、kkにしてあります。 変数名は好きな名前を付ければ良いので 後で見た時に分かりやすい物にしておくのが良いと思います。 細かい事ですが、mr の由来は上記ですので mr って変数名なのに 最大行数が入っていないまま 他の部分で使ってあると、mr の名が廃ると言うか 「じゃあ、mrじゃ無くて良いじゃん」とか思って仕舞います。 もしも、Ｍove-Ｒow とかだったら mr でも良さそうですが 変数名ってこじつけるような物でも無いと思いますので。 ・・・まぁ、どんな名前の変数に何が入っていても 間違えて使うのでなければ動きとしては関係ないですが。 例えば、今回は転記先行を mr に入れるとして 　kkがエラー値だった時はmrに最終行+1 の行番号を入れる 　エラー値でなければ mr に kk の値を入れる の様に一つにまとめておけば、実際に転記する部分で mr に成っている物と、kk に成っている物 を 二つ作る必要が無くなります。 ＞折角作りましたので この気持ちは分からないでも無いですが。。。 これを使う方にとってはどうでしょう？ 登録ボタンを押すべきなのか、修正ボタンを押すべきなのか 押してみないと分かりませんよね？ 　（まぁ、大抵は修正ボタンで良いのでしょうけど。） もしも逆を押したら、もう一度本来のボタンを押す必要が有ります。 場合によってはその様にしておいた方が良い事も有ると思いますが 今回の場合、その様にしておく必要が有るかどうか　疑問に思います。 また、入力項目数が変わった場合はどうでしょう？ 許斐さんは、二つのコードを変更しなくてはいけませんね。 しかも、この二つに関しては同じ所を、同じ様に 修正する事になりますね。 勿論、両方のコードを細心の注意を持って 変更しなくてはいけません。 それって、面倒じゃないですか？ (HANA) ---- HANA　さん ＞それって、面倒じゃないですか？ 面倒ですねー。− 呼び出しもできたことだしやってみます。 ＞見つからなかったら、最終行+1 の行を転記先行の変数に入力。 ＞見つかったら、その値を転記先行の変数に入力。 ＞続いて、実際に 転記先行の変数 の行に転記。 mrのところを 修正の場合は Application.Match(Range("E4").Value, Worksheets("採寸表").Range("A:A"), 0) 登録の場合は .Range("A" & Rows.Count).End(xlUp).Row + 1 をIFで判断させ入れ替えさせるていうことですか？ (許斐） ---- ＞をIFで判断させ入れ替えさせるていうことですか？ そうですね。 先ほどのコメントで「例えば」と書いたように どちらをどちらに入れるのか 　mr を kk に入れるのか、kk を mr に入れるのか とか 何に入れるのか 　新しい変数に 状況に依って kk 或いは mr を入れる とか その辺りは、好き好きに成ってくると思います。 (HANA) ---- HANA　さん 検索してみましたが、分かりませんでした。 こんな感じでしょか？？ 　　　kk = Application.Match(Range("E4").Value, Worksheets("被服貸与").Range("A:A"), 0) 　　　If IsNumeric(kk) Then MsgBox kk & "行目に重複の職員番号がありました。データを上書きします。" mr = kk Else '↓ダブりがないときの処理 MsgBox kk & "に該当するデータがありません。新規登録します。" mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 　　　End　if 　　With Sheets("被服貸与") mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 ↑の場合はどうすれば？？？？？ （許斐）　 ---- そんな感じです。 でもちょっと違います。 一つずつ行きますと MsgBox kk & "に該当するデータがありません。新規登録します。" mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 ここの所が／~~~~~~~ コンパイルエラーに成りませんか？ kk = Application.Match(Range("E4").Value, Worksheets("被服貸与").Range("A:A"), 0) ここでは、ちゃんとシート名を書いているのに~~~~~~~~~~~~~~~~~~~~~~ それから、見つからなかった時 kkは「エラー2402」って成っているので MsgBox kk & 〜 の部分で、実行時エラーが出ますね。 IsNumeric(kk) を判定して Else だったら 「kk & "に該当するデータがありません。」 どこに　該当するデータが無い　と メッセージを出したいのでしょう？ 現在の状態から動くようにするには どのシートに関する処理なのかを書く事と ダブりがない時はメッセージだけを表示させる事にして kk = Application.Match(Range("E4").Value, Worksheets("被服貸与").Range("A:A"), 0) If IsNumeric(kk) Then MsgBox kk & "行目に重複の職員番号がありました。データを上書きします。" mr = kk Else '↓ダブりがないときの処理 MsgBox "該当するデータがありません。新規登録します。" mr = Worksheets("被服貸与").Range("A" & Rows.Count).End(xlUp).Row + 1 End If 　　With Sheets("被服貸与") に変更。 ただ先ほども書きました様に ＞With Sheets("被服貸与") の中（下）に kk = Application・・・等を入れると Worksheets("被服貸与")の部分を書かずに済みます。 With Sheets("被服貸与") kk = Application.Match(Range("E4").Value, .Range("A:A"), 0) If IsNumeric(kk) Then '~~★こことか MsgBox kk & "行目に重複の職員番号がありました。データを上書きします。" mr = kk Else '↓ダブりがないときの処理 MsgBox "該当するデータがありません。新規登録します。" mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 End If '~~★ここ With △△ 〜 End With の間に入っている「.○○」は その . の前に　△△が付いていると言うお約束です。 ＞↑の場合はどうすれば？？？？？ mr には　転記先の行番号が既に入っていますので 再度入れる必要は無いと思います。 ・・・と言うか、上書きの場合　せっかく mr に kk の値を入れても ここで 最終行+1 を入れてしまっては意味が無いと思いますが。 それから、被服貸与シートと　サイズシートへは 同時に書き出し　同時に入力　と言うお約束なので mr の値を流用しても良いのかもしれませんが 何かの拍子にずれてしまうかもしれませんので その都度取得するのが良さそうに思います。 となると 「kk & "行目に重複の職員番号がありました。」 の様にどちらかのシートに限定した情報は 表示しなくても良いのではないかと思います。 そんなことを言い始めると 事前に両方のシートでデータを確認して 「○○には有るけど××にはないので 　○○は上書きして××は新規登録するよ」 までやるのが正当かもしれませんが。。。 そこまでする必要が有るのかどうかは疑問に思います。 (HANA) ---- HANA　さん お！すごい一個できました。 サイズをこんな風にしてみました。 With Sheets("採寸表") kk = Application.Match(Range("E4").Value, .Range("A:A"), 0) If IsNumeric(kk) Then mr = kk Else '↓ダブりがないときの処理 mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 End If 最終行に転記する際 転記もとの上の行の書式をコピーできたら 書式がきれいに整えられますね。 （許斐） ---- ＞最終行に転記する際 ＞上の行の書式をコピーできたら ＞書式がきれいに整えられますね。 データシートに書式を設定してるんですか？ ・・・とか言ってみる。。。 えっと、どんな書式なんでしょう？ 罫線かな？ そうなると、 ＞Else '↓ダブりがないときの処理 で、mr に最終行を入れるのと 一緒にコピーするのが良いかもしれませんね。 ストイックに書式のコピーでも良いですが。。。 おおざっぱにこんな感じでも。 Else '↓ダブりがないときの処理 mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 .Range("A" & mr - 1).EntireRow.Copy .Range("A" & mr) .Range("A" & mr).EntireRow.ClearContents End If (HANA) ---- HANA　さん ＞えっと、どんな書式なんでしょう？ 罫線かな？ 　はい。罫線です。太線と細線。。。。 　 　ありがとうございます。思い通りの結果を得ることができました。 　私のコードと何が違うのでしょか？ Else '↓ダブりがないときの処理 mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 '1行上の行をコピー Range(mr - 1 & ":" & mr - 1).Copy '挿入行に貼り付け Range("A" & mr).Selection.PasteSpecial Paste:=xlPasteFormats, 　Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False End If もし数式をコピーする場合数式ある行判定できたりしますか？ （許斐） ---- ＞私のコードと何が違うのでしょか？ ＝「動かないけどどこが悪いの？」 って事なら一番の理由は Range("A" & mr).Selection.PasteSpecial Paste:=xlPasteFormats ~~~~~~~~~~これが不要。 それから、 　Range(mr - 1 & ":" & mr - 1).Copy 　Range("A" & mr).Selection.PasteSpecial ・・・ これではアクティブシートに対して実行されます。 コードを作る時は　どのシートに対して実行したいのか 気をつけておかれるのが良いと思います。 　.Range("A" & Rows.Count).End(xlUp).Row これは、With Sheets("採寸表")　の中に有るなら 採寸表シートに対して実行されます。 ＞もし数式をコピーする場合数式ある行判定できたりしますか？ ちょっと意味が分かりません。。。 どういう事でしょう？ (HANA) ---- HANA さん ＞これではアクティブシートに対して実行されます。 　そうだったんですか。。。 ＞＞もし数式をコピーする場合数式ある行判定できたりしますか？ ＞ ちょっと意味が分かりません。。。 　EとG列に数式を入力しています。 　書式とともにコピーできないかと。。。。手動しなくすみます。。。 （許斐） ---- ＞そうだったんですか。。。 そうなんですよ。（涙） ＞【アクティブブックの】Sheet1のデータを ＞Book2とBook3にそれぞれ転記するコード ＞ With Workbooks("Book2.xls").Sheets("Sheet2") ＞ mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 ＞ .Cells(mr, 1).Value = Sheets("Sheet1").Range("E1").Value '職員番号 ＞ End With ★~~ここにブック名が無いのでアクティブブック ＞マクロ実行ボタンをBook1のSheet1に置くことにして ＞そこからしか実行しない状況にしておけば ＞ .Cells(mr, i + 3).Value = Sheets("Sheet1").Range("B" & i + 20).Value ＞ここにシート名を入れて限定していますが／~~~~~~~~~~~~~~~~~~ ＞この部分も無くして仕舞っても良さそうですね。 コードを↓の様に変更したら .Cells(mr, i + 3).Value = Range("B" & i + 20).Value ここにシート名が無いので~~アクティブシート 前スレでは「Sheet1がアクティブに成っている」と言う条件を付けて Sheets("Sheet1").を消しましたね。 ＞EとG列に数式を入力しています。 ・・・じゃあ、書式コピーの後で個別にコピーでもしますか。 .Range("E" & mr - 1).Copy .Range("E" & mr) .Range("G" & mr - 1).Copy .Range("G" & mr) (HANA) ---- HANAさん ありがとうございます。 検証結果は明日報告します。 こんな贅沢なマクロはありますか？ 指定した行にスクロールする。 貸出し表は100列以上あり、項目探すとき大変です。 A&B列と1行目は画面固定しています。 マクロでT列を検索するとB列の隣にT列スクロールさせることてできますか？ A] B] T] 1] 許斐 ---- HANA さん ＞じゃあ、書式コピーの後で個別にコピーでもしますか。 　上手くいきました。ありがとうございます。 ＞マクロでT列を検索するとB列の隣にT列スクロールさせることてできますか？ 　あったんですね。何気に調べたら見つけました。びっくりです。 列指定してスクロールは可能ですが、 　項目指定してその行にスクロールは難しいですね（−、−） （許斐） ---- ＞あったんですね。何気に調べたら見つけました。びっくりです。 どんなコードに成っていますか？ 単純に列番号を指定しているだけなら 今回の場合でも　MATCH関数で検索すれば良いと思いますが。 但し、曖昧検索は難しいので きっちり入力しないといけませんが。 (HANA) ---- HANA さん ＞MATCH関数で検索すれば良いと思いますが。 　そうなんですか。入れてみます。 ＞どんなコードに成っていますか？ こんな感じです。 まだ思い通りに実行できませんが。。。。 Sub 指定した行番号が上端になるようにウィンドウをスクロールする() シート名 = "Sheet1" '※1 Worksheets(シート名).Activate 行番号 = 2 '※2 ActiveWindow.ScrollRow = 行番号 End Sub Sub 指定した列番号が左端になるようにウィンドウをスクロールする() シート名 = "Sheet1" '※1 Worksheets(シート名).Activate 列番号 = 3 '※2 ActiveWindow.ScrollColumn = 列番号 End Sub Sub アクティブシートのA1セルを選択してウィンドウをスクロールする() Application.Goto Range("A1") '※3 End Sub Sub 指定シートの指定セルを選択してウィンドウをスクロールする() シート名 = "Sheet1" '※1 セル番号 = "E25" '※4 Application.Goto Reference:=Worksheets(シート名) .Range (セル番号), scroll:=True '※5 End Sub (許斐） ---- ＞＞MATCH関数で検索すれば良いと思いますが。 ＞　そうなんですか。入れてみます。 ん？もしかして MATCH関数で何を求めているか イメージがつかめてない？ ＞まだ思い通りに実行できませんが。。。。 って事は、私のイメージと 実際になさりたい事が違うのかな？ (HANA) ---- HANA　さん ＞MATCH関数で何を求めているか 　B1に入力した項目名をA2〜ラストと同じ値のところまでスクロールする？ ＞って事は、私のイメージと 　は分かりませんが、↓にしたところ有効な範囲にありませんとばかりで、進まない状況です（−、−） Sub 指定した列番号が左端になるようにウィンドウをスクロールする() シート名 = "貸出" '※1 Worksheets(貸出).Activate mr = Application.Match(Range("B1").Value, Range("A2").End(xlToRight).Column, 0) ActiveWindow.ScrollColumn = mr End Sub （許斐） ---- B1に入力した項目名をA2〜ラストと同じ値のところまでスクロールする コードを作りたいんですよね？ 私の質問は 「MATCH関数で何を求めているか？」 なんですけどね。 因みに・・・ ＞Range("A2").End(xlToRight).Column なんで Column なんですか？ Range("A2").Column これって、A列の事です。 例えば、BB列まで見出しが入っていた場合 Range("A2").End(xlToRight) は BB2 セルなので Range("A2").End(xlToRight).Column だと BB列の事になりますね。 (HANA) ---- HANA　さん >B1に入力した項目名をA2〜ラストと同じ値のところまでスクロールする はいB1人入力した項目名をA2〜DK2と同じ値のところまでスクロールするです。 ↓になるということですね。 mc = Application.Match(Range("B1").Value, Range("A2").End(xlToRight), 0) ＞シート名 = "貸出" '※1 ＞ Worksheets(貸出).Activate エラーになり、 Worksheets("貸出").Activateにしたところ ＞ActiveWindow.ScrollColumn = mr　 がエラーになり もしかして、使っているコードそのものが違ったり・・・・。 （許斐） ---- 分かりました。 色々やっている内に 色々問題が有りそうに思います。 まず、変数の宣言をしないと動かない様にしましょう。 コードを書く画面の一番上に 　Option Explicit の一行を入れて下さい。 これで、dim ○○　と書いていない変数は 使えないことに成ります。 ＞シート名 = "貸出" '※1 ＞ Worksheets(貸出).Activate これはタブン ~~~~ここが変数扱いに成っていて 何も入っていないので　エラーに成っているかな？ それから ＞↓になるということですね。 ＞mc = Application.Match(Range("B1").Value, Range("A2").End(xlToRight), 0) 違います。 ＞＞例えば、BB列まで見出しが入っていた場合 ＞＞Range("A2").End(xlToRight) は BB2 セル の事です。 =MATCH(B1,BB2,0) と言う数式で得られる結果が mc に入ることに成ります。 それから、ステップインで実行して mc に希望する値が入っている事を 確認していますか？ 　ActiveWindow.ScrollColumn = ・・・ 部分を実行するのは、希望する値を 得られるように成ってからです。 因みに ＞ActiveWindow.ScrollColumn = mr　 もしもその上の部分のコードが ＞mc = Application.Match(Range("B1").Value, Range("A2").End(xlToRight), 0) なら、これ又変数が違いますね。 部分的だけを載せるのではなく 全体を載せた後、「この部分が！！」と 書くようにして頂ければと思います。 それから、「エラーに成ります」だけでなく エラーメッセージが何と表示されるのかも　書いて下さい。 エクセルが許斐さんに注進している言葉です。 (HANA) ---- MATCH関数については そんなに難しく考えなくても良いと思うのですが。。。 被服貸与シートのA列の中から E4セルの値を探すときは =MATCH(E4,被服貸与!A:A,0) で、これをコードにすると↓ = Application.Match(Range("E4").Value, Worksheets("被服貸与").Range("A:A"), 0) もしもアクティブシートのA列から探すなら「Worksheets("被服貸与").」が省略出来て kk = Application.Match(Range("E4").Value, Range("A:A"), 0) ですよね。 2行目からB1セルの値を探すときは =MATCH(B1,2:2,0) ですから、コードにすると = Application.Match(Range("B1").Value, Range("2:2"), 0) で良いんじゃないですか？ (HANA) ---- HANA　さん エラーは「型が一致しません。」 ちゃんと範囲を指定したところ上手くいきました。 Private Sub 検索_Click() Dim mr Worksheets("被服貸与").Activate mr = Application.Match(Range("B1").Value, Range("A2:DK2"), 0) If IsNumeric(mr) Then ActiveWindow.ScrollColumn = mr Else MsgBox "一致項目がありません。" End If End Sub Range("2:2") でよかったんですね＾＾ 本当にありがとうございます。これにてすべて完成しました。　m(_ _)m また何かありましたら、よろしくお願いします。 (許斐） ---- HANAさん最後までご指導していただいたおかげで、いろいろ付け加えることができ、 気づけばすごいものができました。＾＾ (自己満足） Sub 登録修正() Dim mr As Long Dim i As Long, ii As Long, cn As Long Dim kk Dim msg As String '氏名と職員番号チェック If Range("B5").Value = "" Then msg = vbLf & "氏名を入力してください。" End If If Range("E4").Value = "" Then msg = msg & vbLf & "職員番号を入力してください。" End If If Len(msg) Then MsgBox msg Exit Sub End If '重複職員NOチェック With Sheets("被服貸与") kk = Application.Match(Range("E4").Value, .Range("A:A"), 0) If IsNumeric(kk) Then MsgBox kk & "行目に重複の職員番号がありました。データを上書きします。" mr = kk Else '↓ダブりがないときの処理 MsgBox "該当するデータがありません。新規登録します。" mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 '上の行の書式を下の行にコピー .Range("A" & mr - 1).EntireRow.Copy .Range("A" & mr) .Range("A" & mr).EntireRow.ClearContents '上の行の数式を下の行にコピー .Range("E" & mr - 1).Copy .Range("E" & mr) .Range("G" & mr - 1).Copy .Range("G" & mr) End If .Cells(mr, 1).Value = Range("E4").Value '職員番号 .Cells(mr, 2).Value = Range("B5").Value '氏名 .Cells(mr, 3).Value = Range("B4").Value 'ふりがな .Cells(mr, 4).Value = Range("E5").Value '生年月日 .Cells(mr, 6).Value = Range("H5").Value '採用年月日 .Cells(mr, 8).Value = Range("H4").Value '階級 .Cells(mr, 9).Value = Range("J4").Value '所属 cn = 9 '9行目〜の設定 For i = 7 To 18 '行番頭 i = 1 For ii = 2 To 4 '列番号 cn = cn + 1 .Cells(mr, cn).Value = Cells(i, ii).Value Next Next For i = 7 To 17 '行番号 i = 1 For ii = 6 To 8 '列番号 cn = cn + 1 .Cells(mr, cn).Value = Cells(i, ii).Value Next Next For i = 7 To 18 '行番号 i = 1 For ii = 10 To 12 '列番号 cn = cn + 1 .Cells(mr, cn).Value = Cells(i, ii).Value Next Next .Cells(mr, 115).Value = Range("F18").Value '備考 End With 'サイズ With Sheets("採寸表") kk = Application.Match(Range("E4").Value, .Range("A:A"), 0) If IsNumeric(kk) Then mr = kk Else '↓ダブりがないときの処理 mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 .Range("A" & mr - 1).EntireRow.Copy .Range("A" & mr) .Range("A" & mr).EntireRow.ClearContents End If .Cells(mr, 1).Value = Range("E4").Value '職員番号 .Cells(mr, 2).Value = Range("B5").Value '氏名 .Cells(mr, 3).Value = Range("B4").Value 'ふりがな For i = 1 To 5 '頭,首,胸囲 .Cells(mr, i + 3).Value = Range("B" & i + 20).Value Next For i = 1 To 4 'ｷｬｯﾌﾟ,シャツ,上着,ズボン .Cells(mr, i + 8).Value = Range("D" & i + 20).Value .Cells(mr, i + 12).Value = Range("F" & i + 20).Value .Cells(mr, i + 16).Value = Range("H" & i + 20).Value Next .Cells(mr, 21).Value = Range("D25").Value End With End Sub （許斐） ---- 衝突しちゃいました。。。 ＞Range("2:2") でよかったんですね 範囲を指定すると、項目が増えたときに コードを変更しないといけないので なるべくそうならずに済むようにしておくのが良いと思います。 　これは、RANGE("2:2")やRANGE("A:A")の様にするのがよい 　と言う事ではなく、Range("A2:DK2") の様に 　直接書かない方が良い　って事です。 それと、インデントはつけておいた方が良いと思います。 動きには関係有りませんが どこがどこと対応しているのか分かりやすくなると思いますので。 因みに、登録マクロの最後に セルのクリアまでやっていますよね？ ＞呼び出しもできたことだしやってみます。 と言う事ですが 呼び出し部分のコードはどの様に成りましたか？ ・・・って書いてたら衝突しちゃったので。。。 載せて下さったコードに関して。 登録・上書きしたら、セルの値をクリアをするのですよね？ それから、最初の ＞kk = Application.Match(Range("E4").Value, Worksheets("貸出").Range("A:A"), 0) って要りますか？ また、変数の「WS As Worksheet」も使われて居ない様な。。。？ (HANA) ---- HANA　さん ＞これは、RANGE("2:2")やRANGE("A:A")の様にするのがよい 　なるほど覚えておきます。 ＞kk = Application.Match(Range("E4").Value, Worksheets("貸出").Range("A:A"), 0) ＞変数の「WS As Worksheet」 　う！必要性ないですね。。 自分で見直したつもりが抜けてますね＾＾；；； ＞呼び出し部分のコードはどの様に成りましたか？ >登録・上書きしたら、セルの値をクリアをするのですよね？ はいそうです。 呼出は自動クリアできないので、クリアボタンを作成し手動でしてもらうつもりです。。。 Sub 呼出() Dim mr As Long Dim i As Long, ii As Long, cn As Long Dim kk Dim msg As String kk = Application.Match(Range("E4").Value, Worksheets("貸出").Range("A:A"), 0) '重複職員NOチェック If Not IsNumeric(kk) Then MsgBox "該当するデータがありません。" Else '↓ダブりがないときの処理 　　'氏名等 Range("B4:C5,E5:F5,H4,H5:I5,J4").ClearContents '貸し出し Range("B7:D18,F7:H18,J7:L18").ClearContents 'サイズ Range("B21:B25,D21:D24,F21:F24,H21:H24,D25:H25").ClearContents '服 With Sheets("貸出") mr = Application.Match(Range("E4").Value, .Range("A:A"), 0) Range("E4").Value = .Cells(mr, 1).Value '職員番号 Range("B5").Value = .Cells(mr, 2).Value '氏名 Range("B4").Value = .Cells(mr, 3).Value 'ふりがな Range("E5").Value = .Cells(mr, 4).Value '生年月日 Range("H5").Value = .Cells(mr, 6).Value '採用年月日 Range("H4").Value = .Cells(mr, 8).Value '階級 Range("J4").Value = .Cells(mr, 9).Value '所属 cn = 9 '9行目〜の設定 For i = 7 To 18 '行番頭 i = 1 For ii = 2 To 4 '列番号 cn = cn + 1 Cells(i, ii).Value = .Cells(mr, cn).Value Next Next For i = 7 To 17 '行番号 i = 1 For ii = 6 To 8 '列番号 cn = cn + 1 Cells(i, ii).Value = .Cells(mr, cn).Value Next Next For i = 7 To 18 '行番号 i = 1 For ii = 10 To 12 '列番号 cn = cn + 1 Cells(i, ii).Value = .Cells(mr, cn).Value Next Next Range("F18").Value = .Cells(mr, 115).Value '備考 End With 'サイズ With Sheets("サイズ") mr = Application.Match(Range("E4").Value, .Range("A:A"), 0) For i = 1 To 5 'B21〜 Range("B" & i + 20).Value = .Cells(mr, i + 3).Value Next For i = 1 To 4 'D21〜 Range("D" & i + 20).Value = .Cells(mr, i + 8).Value Range("F" & i + 20).Value = .Cells(mr, i + 12).Value Range("H" & i + 20).Value = .Cells(mr, i + 16).Value Next Range("D25").Value = .Cells(mr, 21).Value '靴 End With End If End Sub （許斐） ---- えっと... ＞＞これは、RANGE("2:2")やRANGE("A:A")の様にするのがよい 【と言う事ではなく】 ですよ？ 今回の場合は、MATCH関数の範囲として使用するので そんなに問題には成らないと思いますが 多くの場合は、範囲を自動的に検出して その範囲で処理を行う方が良いと思います。 ＞＞登録・上書きしたら、セルの値をクリアをするのですよね？ ＞はいそうです。 でも、載せて居られるコードには　その部分が無い様ですが。。。？ 　Call 値をクリア とか、やっておきましょう。 それから、載せて下さった Sub 呼出() のコードは動きませんね？ ＞Dim kk As Worksheet って成ってますし。。。 (HANA) ---- HANA　さん ＞でも、載せて居られるコードには　その部分が無い様ですが。。。？ Private Sub 登録_Click() Call 登録修正 Call 値をクリア MsgBox "処理終了しました。" End Sub こっちに乗ってます。＾＾；； ＞Dim kk As Worksheet Dim kk As Long ですね　（−、−） Dim kk ,WSAs Worksheetを直したらそのままでした。。。 (許斐） ---- ＞Dim kk As Long ＞ですね　（−、−） まぁ、ここも含め　新規データだった時は エラーになって止まりますね？ それから 「Worksheets("貸出")」とか 「Worksheets("サイズ")」は With を使ってまとめてみませんか？ (HANA) ---- HANA　さん ↑両方のコードを修正しました。 (許斐） ---- だいぶすっきりしましたね。 If Not IsNumeric(kk) Then の時もE4以外は ClearContents する事にしてはどうでしょう？ さらに考えると マクロが実行された時点で データが有っても無くても E4以外は一端 ClearContents しても 良さそうに思います。 その時に「値をクリア」が流用出来ると良いですね。。。 例えばこのマクロを「職員番号以外の値をクリア」と言う名称にして 職員番号までクリアしたいときは　個別に　削除する事にするとか。 (HANA) ---- HANA　さん なるほど。 そうですね。そうします。 よりいっそスマートになりますね。 （許斐） ---- それと、思ったのですが 貸出シートだけを確認して 「新規登録です」と決めるのは 早計じゃないでしょうか。 勿論、両方のデータは揃っているはずなんですが 何かの手違いで サイズシート の方だけデータが有ったり または、貸出シートの方だけデータが有って サイズシートの方にはデータが無かったり。。。 なんて状況に成るかも知れません。 両方で確認　＆　両方の転記が終わってから メッセージを出すことにしても 遅くはないんじゃないかと思います。 どうせ転記は一瞬で終わって仕舞いますよね？ (HANA) ---- HANAさん kk = Application.Match(Range("E4").Value, Worksheets("貸出").Range("A:A"), 0) ^^^^^^^^^^^^^^^^^^^^^^^^^^をサイズ追加する？ もう一個作る？⁇ (許斐) ---- 済みません。 ＞その時に「値をクリア」が流用出来ると良いですね。。。 ＞例えばこのマクロを「職員番号以外の値をクリア」と言う名称にして ＞職員番号までクリアしたいときは　個別に　削除する事にするとか。 と思ったのですが、「値をクリア」マクロは 単独でも実行したいですよね。 となると、「値をクリア」ではE4セルの値もクリアする事にして E4の値を残しておきたいときに 　変数に入れておいて、クリア後戻す と言う作業にした方が良い様に思いました。 ＞両方で確認　＆　両方の転記が終わってから ＞メッセージを出す は、例えば（↑で思った事も含め） 動作確認をしてませんが。。。 '------ Sub 呼出_最後にメッセージ() Dim kv, mr Dim i As Long, ii As Long, cn As Long Dim flg As Long 'E4以外の値削除 kv = Range("E4").Value Call 値を削除 Range("E4").Value = kv '貸出 With Sheets("貸出") mr = Application.Match(kv, .Range("A:A"), 0) If IsNumeric(mr) Then flg = 1 Range("E4").Value = .Cells(mr, 1).Value '職員番号 Range("B5").Value = .Cells(mr, 2).Value '氏名 Range("B4").Value = .Cells(mr, 3).Value 'ふりがな Range("E5").Value = .Cells(mr, 4).Value '生年月日 Range("H5").Value = .Cells(mr, 6).Value '採用年月日 Range("H4").Value = .Cells(mr, 8).Value '階級 Range("J4").Value = .Cells(mr, 9).Value '所属 cn = 9 '9行目〜の設定 For i = 7 To 18 '行番頭 i = 1 For ii = 2 To 4 '列番号 cn = cn + 1 Cells(i, ii).Value = .Cells(mr, cn).Value Next Next For i = 7 To 17 '行番号 i = 1 For ii = 6 To 8 '列番号 cn = cn + 1 Cells(i, ii).Value = .Cells(mr, cn).Value Next Next For i = 7 To 18 '行番号 i = 1 For ii = 10 To 12 '列番号 cn = cn + 1 Cells(i, ii).Value = .Cells(mr, cn).Value Next Next Range("F18").Value = .Cells(mr, 115).Value '備考 End If End With 'サイズ With Sheets("サイズ") mr = Application.Match(kv, .Range("A:A"), 0) If IsNumeric(mr) Then flg = flg + 2 Range("E4").Value = .Cells(mr, 1).Value '職員番号 Range("B5").Value = .Cells(mr, 2).Value '氏名 Range("B4").Value = .Cells(mr, 3).Value 'ふりがな For i = 1 To 5 'B21〜 Range("B" & i + 20).Value = .Cells(mr, i + 3).Value Next For i = 1 To 4 'D21〜 Range("D" & i + 20).Value = .Cells(mr, i + 8).Value Range("F" & i + 20).Value = .Cells(mr, i + 12).Value Range("H" & i + 20).Value = .Cells(mr, i + 16).Value Next Range("D25").Value = .Cells(mr, 21).Value '靴 End If End With '新規時メッセージ If flg = 0 Then MsgBox "新規データです。" End If End Sub '------ まず 　E4セルの値を kv に入れて 　データをクリア 　E4セルに値を戻す それから、貸出シートに関して 　データを探し、入力が有れば 　flg に「1」を入力 　データを転記 続いて　サイズシートに関して 　データを探し、入力が有れば 　flg に「flg +2」を入力 　データを転記 最後に 　flg の値が 0 のままなら 　どちらのシートにもデータが無かったと言う事なので 　メッセージを表示。 と言う流れです。 サイズシートに関しても 　flg に「1」を入力 でも良いのですが、+2 の様にしておくと flg = 0 の時　どちらにもデータ無し 　flg = 1 の時　貸出シートにのみ　データ有り 　flg = 2 の時　サイズシートにのみ　データ有り 　flg = 3 の時　両方のシートにデータ有り と、値によって状況がどうだったのか分かります。 今回は何れにしても、0か0でないか　の判断しか しないと思うので　その様にしておく利点はあまり無いのですが。。。 (HANA) ---- HANA さん すごいです。ばっちりです（☆。☆） メッセージこういう使い方あるんですね。 〆(。・)ﾒﾓﾒﾓ　また一つ勉強になりました。 （許斐） ---- ＞メッセージこういう使い方あるんですね。 が、どういう使い方を言って居られるのか よく分かりませんが。。。（flg の事かな？） 必要な処理をやった後で、メッセージを表示させるかどうか決める って事であれば、意識して居られないだけで、「登録修正」で 使って居られるテクニックだと思います。 If Len(msg) Then MsgBox msg Exit Sub End If で、見ていて思ったのですが 「登録修正」のコードのこの部分で Exit Sub して仕舞うと Call 値をクリア が実行されて、せっかく入力したデータが クリアされて仕舞いません？ (HANA) ---- HANA さん ＞使って居られるテクニックだと思います。 ＞If Len(msg) Then ＞ MsgBox msg ＞ Exit Sub ＞ End If 見つけてきたものそのまま使っただけです＾＾；；；；；；；； ＞Exit Sub して仕舞うとCall 値をクリア 本当ですね（ToT)消して サイズにまま実行されてしまいました。 考えてみたらサイズのほうはチェックしていないですね。 (許斐） ---- HANA さん こっちに入れたところ 値は消えませんでした。このメッセージはこういう使い方ですね（？？）違いが良く分からない。。。。。 Private Sub 登録_Click() Dim msg As String '氏名と職員番号チェック If Range("B5").Value = "" Then msg = vbLf & "氏名を入力してください。" End If If Range("E4").Value = "" Then msg = msg & vbLf & "職員番号を入力してください。" End If If Len(msg) Then MsgBox msg Exit Sub End If Call 登録修正 Call 値をクリア MsgBox "処理終了しました。" End Sub (許斐） ---- ＞＾＾；；；；；；；； 見つけたときに「どうなってるんだ？」 って思えると良いですね。 ＞考えてみたらサイズのほうはチェックしていないですね。 でも、「登録修正」の方はメッセージだけですからね。 気になる様なら変更してもらえば良いと思いますが。 ＞こっちに入れたところ ＞値は消えませんでした。 消えないと思いますが。。。。 最初に作って居られた「登録修正」を 「Private Sub 登録_Click」 にして、その中で 　Call 値をクリア すれば良いのでは？ 最初に作って居られたコードと 「こっちに入れた」コードの違いは ステップインで実行してもらうと 分かりやすいと思います。 ◆どこから Eixt するのか？ Private Sub 登録_Click() Call 登録修正　←−−−−−◆ Call 値をクリア MsgBox "処理終了しました。" End Sub Call されて「登録修正」のコードを実行中に その中で Exit Sub した場合、その処理（登録修正）を終了して 「登録_Click」のコードへ戻って来ます。 で、次の処理「値をクリア」のコードが実行されます。 Private Sub 登録_Click() Dim msg As String '氏名と職員番号チェック If Range("B5").Value = "" Then msg = vbLf & "氏名を入力してください。" End If If Range("E4").Value = "" Then msg = msg & vbLf & "職員番号を入力してください。" End If If Len(msg) Then MsgBox msg Exit Sub　←−−−−−◆ End If Call 登録修正 Call 値をクリア MsgBox "処理終了しました。" End Sub 「登録_Click」の中で Exit Sub した場合 その処理（登録_Click）を終了します。 Call ○○ ってやると　続けて処理がされるので コードをコピペしたのと同じ様な結果に成りますが 全く同じと言う訳ではありませんので その違いに気をつけてもらうのが良いと思います。 (HANA) ---- HANA　さん ありがとうございます。＾＾ 理解できました。 （許斐） ---- これで、一通り出来たんですよね？ 後は、「呼出」は こんな感じで仕込んでおくと良いかな？ と思いますが、どうでしょう。 http://www.excel.studio-kazu.jp/mag2/backnumber/mm20040727.html ↑エクセルマイスター「Worksheet_SelectionChange」 前スレでちょっと呟いた ＞＞職員NO存在チェック ＞は、E4セルに番号が入力された段階で ＞行うのが良いのではないかと思います。 ＞ ＞そして、その際 ＞重複があったらそのデータを各セルに呼び出す。 ＞　登録と逆をやれば大丈夫だと思います。 ＞重複が無かったら、各セルのデータをクリア。 ＞　ただし、E4セルには　入力したデータが ＞　残っていないといけませんが。 ＞って感じで出来ると良さそうですね。 の部分です。 「そして、その際〜」の基本的な部分は完成しましたので あとは、「E4セルにデータを入力したら」のタイミングで 自動的に実行するようにします。 それ以外では実行されないような処置も必要ですが。 (HANA) ---- HANA さん にしたところ 何も起こりません。。。。。 集計シートは集計してくれたのに。。。なぜ？？ Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "E4" Then Exit Sub Call 呼出2 End Sub （許斐） ---- あ。。。エクセルマイスターはSelectionChangeでしたね。 失礼しました。 Worksheet_Changeイベントを使ったコードを作る時は 面倒ですが、ブレークポイント等を設定し 一度コードを止め、ステップインで実行するようにしておくのが 良いと思います。 途中でやめられなくなる可能性が有りますし 思っている所と違う所で発動して居る場合に 気づきやすいですから。 ＞なぜ？？ と言われても、何をやったのか分かりませんので こちらからは分かりません。。。 まずは、どの様に動いているのか ステップインで確認してみて下さい。 (HANA) ---- HANA さん 「スタック領域が不足している」 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address(0, 0) <> "E4" Then Exit Sub Call 呼出　　←････････◆ End Sub ◆のところは使用できないのですか？ ---- ステップインで実行していますか？ 「Call 呼出」が何度も実行されているんじゃないかと思いますが。。。？ (HANA) ---- HANA　さん ＞ステップインで実行していますか？ 行ったり着たり行ったりきたり。。。。。。。。。。。。 回避方法はないのですか？ 「削除」ように見つかってらとめる。 （許斐） ---- そこで　エクセルマイスター「Worksheet_SelectionChange」の (5)Worksheet_SelectionChangeの基本 につながります。 人がE4セルを変更したのではなく 「呼出」のマクロがE4を変更したから Worksheet_Changeが又実行されますね。 今後は、マクロがセルを変更する時は イベントが起きないように 　Application.EnableEvents = False としておいて 処理が終わったら またイベントが実行されるように 　Application.EnableEvents = True にしてマクロを終了します。 まずは呼出の方から。。。 '------ Private Sub Worksheet_Change(ByVal Target As Range) Dim kv, mr Dim i As Long, ii As Long, cn As Long Dim flg As Long If Target.Address(0, 0) <> "E4" Then Exit Sub Application.EnableEvents = False '◆イベント無効 On Error GoTo Err '● '===E4以外の値削除=== kv = Range("E4").Value Call 値を削除 Range("E4").Value = kv '========貸出======== With Sheets("貸出") mr = Application.Match(kv, .Range("A:A"), 0) If IsNumeric(mr) Then flg = 1 Range("E4").Value = .Cells(mr, 1).Value '職員番号 Range("B5").Value = .Cells(mr, 2).Value '氏名 Range("B4").Value = .Cells(mr, 3).Value 'ふりがな Range("E5").Value = .Cells(mr, 4).Value '生年月日 Range("H5").Value = .Cells(mr, 6).Value '採用年月日 Range("H4").Value = .Cells(mr, 8).Value '階級 Range("J4").Value = .Cells(mr, 9).Value '所属 cn = 9 '9行目〜の設定 For i = 7 To 18 '行番頭 i = 1 For ii = 2 To 4 '列番号 cn = cn + 1 Cells(i, ii).Value = .Cells(mr, cn).Value Next Next For i = 7 To 17 '行番号 i = 1 For ii = 6 To 8 '列番号 cn = cn + 1 Cells(i, ii).Value = .Cells(mr, cn).Value Next Next For i = 7 To 18 '行番号 i = 1 For ii = 10 To 12 '列番号 cn = cn + 1 Cells(i, ii).Value = .Cells(mr, cn).Value Next Next Range("F18").Value = .Cells(mr, 115).Value '備考 End If End With '=======サイズ======= With Sheets("サイズ") mr = Application.Match(kv, .Range("A:A"), 0) If IsNumeric(mr) Then flg = flg + 2 Range("E4").Value = .Cells(mr, 1).Value '職員番号 Range("B5").Value = .Cells(mr, 2).Value '氏名 Range("B4").Value = .Cells(mr, 3).Value 'ふりがな For i = 1 To 5 'B21〜 Range("B" & i + 20).Value = .Cells(mr, i + 3).Value Next For i = 1 To 4 'D21〜 Range("D" & i + 20).Value = .Cells(mr, i + 8).Value Range("F" & i + 20).Value = .Cells(mr, i + 12).Value Range("H" & i + 20).Value = .Cells(mr, i + 16).Value Next Range("D25").Value = .Cells(mr, 21).Value '靴 End If End With '==新規時メッセージ== If flg = 0 Then MsgBox "新規データです。" End If Err: '● '=====エラー確認===== '● If Err > 0 Then '● MsgBox "エラーが発生しました。" & vbLf _ & "（　" & Err() & "　）　" & Error() '● End If '● Application.EnableEvents = True '◆イベント有効 End Sub '------ (HANA) ---- ↑ 異常発生時、Application.EnableEvents = False で 終わらないように処理を追加しました。 「値を削除」のマクロ内でも　イベント発生を止める必要が有るので あちらのコードへも該当部分を追加しておいて頂ければと思います。 (HANA) ---- HANA さん 一回だけ成功して。値クリアクリック後 何も起こりませんでした。（ToT) （許斐） ---- ＞一回だけ成功して。 　E4セルに番号を入力したら 　そのデータが表示された って事ですか？ ＞値クリアクリック後 ＞何も起こりませんでした。 ってのは、 　「値を削除」のマクロを単独で実行したが 　削除されなかった って事ですか？ もう少し順序立てて　何をやってどうなったのか ご説明頂けると良いのですが。。。 (HANA) ---- HANA　さん すみません PCを再起度したところ うまくできました。（強制に。。。） 理由になるかわかりませんが、 モジュール気づかないうちに貸出B00kが二つありました。 開いてるbookは一つですが。。。 (許斐） ---- コードは上の物が貼り付けて有りますか？ また、「値を削除」の方はどの様に成りましたか？ (HANA) ---- HANA　さん すみません＞＜ありがとうございます。 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "E4" Then Exit Sub Call 呼出　←･･････上のコード（If Target.Address <> "E4" Then Exit Sub以外） End Sub 「値を削除」を何度も確認しましたが、問題なく表示されました。 今は何を検証してもちゃんと表示してくれます。 キット変なボタン押したんですね（−、−） （許斐） ---- ＞モジュール気づかないうちに貸出B00kが二つありました。 下記のような現象でしょうか。 [[20040323142216]]　『VBAProjectが残ってしまいます』（VBA初心者） [[20070921103159]]　『ハイパーリンクで呼ばれたブックのクローズ処理異常』（白髪プログラマ）　 いわゆる幽霊プロジェクトと言うヤツですかね・・・ 　 http://www.google.co.jp/search?hl=ja&lr=&safe=off&rlz=1G1GGLQ_JAJP339&q=excel+%E5%B9%BD%E9%9C%8A%E3%83%97%E3%83%AD%E3%82%B8%E3%82%A7%E3%82%AF%E3%83%88&revid=23676984&ei=Te-xSqGOBNWQkQXdmPncCw&sa=X&oi=revisions_inline&resnum=0&ct=top-revision&cd=1 　 (みやほりん)(-_∂)b ---- その様にすると、 Call の中で またCallする事に成るんですよね。。。 それで「Worksheet_Change」で始まる物を載せたのですが。 ＞＞「値を削除」の方はどの様に成りましたか？ これは、コードの事です。 ＞＞あちらのコードへも該当部分を追加しておいて頂ければと思います。 としか書いてないので。 追加しましたか？ (HANA) ---- 幽霊プロジェクトを起動したのはどうやら私です？ リンクではなく練習で自動book openやったときかも？ 呼出にコピーしたのは下のコードのみ。もちろん今も同じです。 Dim kv, mr Dim i As Long, ii As Long, cn As Long Dim flg As Long If Target.Address(0, 0) <> "E4" Then Exit Sub Application.EnableEvents = False '◆イベント無効 On Error GoTo Err '● '===E4以外の値削除=== kv = Range("E4").Value Call 値を削除 Range("E4").Value = kv '========貸出======== With Sheets("貸出") mr = Application.Match(kv, .Range("A:A"), 0) If IsNumeric(mr) Then flg = 1 Range("E4").Value = .Cells(mr, 1).Value '職員番号 Range("B5").Value = .Cells(mr, 2).Value '氏名 Range("B4").Value = .Cells(mr, 3).Value 'ふりがな Range("E5").Value = .Cells(mr, 4).Value '生年月日 Range("H5").Value = .Cells(mr, 6).Value '採用年月日 Range("H4").Value = .Cells(mr, 8).Value '階級 Range("J4").Value = .Cells(mr, 9).Value '所属 cn = 9 '9行目〜の設定 For i = 7 To 18 '行番頭 i = 1 For ii = 2 To 4 '列番号 cn = cn + 1 Cells(i, ii).Value = .Cells(mr, cn).Value Next Next For i = 7 To 17 '行番号 i = 1 For ii = 6 To 8 '列番号 cn = cn + 1 Cells(i, ii).Value = .Cells(mr, cn).Value Next Next For i = 7 To 18 '行番号 i = 1 For ii = 10 To 12 '列番号 cn = cn + 1 Cells(i, ii).Value = .Cells(mr, cn).Value Next Next Range("F18").Value = .Cells(mr, 115).Value '備考 End If End With '=======サイズ======= With Sheets("サイズ") mr = Application.Match(kv, .Range("A:A"), 0) If IsNumeric(mr) Then flg = flg + 2 Range("E4").Value = .Cells(mr, 1).Value '職員番号 Range("B5").Value = .Cells(mr, 2).Value '氏名 Range("B4").Value = .Cells(mr, 3).Value 'ふりがな For i = 1 To 5 'B21〜 Range("B" & i + 20).Value = .Cells(mr, i + 3).Value Next For i = 1 To 4 'D21〜 Range("D" & i + 20).Value = .Cells(mr, i + 8).Value Range("F" & i + 20).Value = .Cells(mr, i + 12).Value Range("H" & i + 20).Value = .Cells(mr, i + 16).Value Next Range("D25").Value = .Cells(mr, 21).Value '靴 End If End With '==新規時メッセージ== If flg = 0 Then MsgBox "新規データです。" End If Err: '● '=====エラー確認===== '● If Err > 0 Then '● MsgBox "エラーが発生しました。" & vbLf _ & "（　" & Err() & "　）　" & Error() '● End If '● Application.EnableEvents = True '◆イベント有効 End Sub '------ 値の削除はいじってません。今もです。 ---- 新しいコードコピー E4に値入力 データ呼出くれた 値の削除クリック E4に値入力 なにも起こらない モジュール確認 二つ発見 間違いでエラー回避コード消し E4に値入力 呼出止まらない 強制終了 無事にできた。。。。 許斐 ---- ＞新しいコードコピー ＞・・・・（中略）・・・・ ＞無事にできた。。。。 は、その時の出来事ですか？ それとも、それ以降におきた出来事ですか？ 現在は 呼出（これはチェンジイベントですが）・クリア・登録・削除 全て問題なく動いていますか？ 念のため、全てのコードの先頭にブレークポイントを設定し 思いがけない所で実行されていないかも 確認して頂ければと思います。 (HANA) ---- HANA さん ＞念のため、全てのコードの先頭にブレークポイントを設定し〜 　いくつかありましたが、自己解決で正常に動きました。＾＾ 　 （許斐） 　 ---- あ〜。。。。 まぁ、解決したなら良かったです。 せっかくですので　全てのコードを 載せてみてもらえませんか？ ＞Private Sub 登録_Click() なんてのが有るときは、それも含めて。 それと、シートには 　クリア・登録・削除 の実行釦が有る状態ですよね？ (HANA) ---- HANAさん あ！衝突。。。ではまずは、 ひつつ教えてください。 B1の検索値を曖昧にする方法。 たとえば konomiを調べるとき 今は　B1に　kono*　入力しています。 希望　B1に　kono　 入力して調べられるようにしたいのです。できますか？？ Private Sub 検索_Click() Dim mr Worksheets("貸出").Activate mr = Application.Match(Range("B1").Value, Range("2:2"), 0) If IsNumeric(mr) Then ActiveWindow.ScrollColumn = mr Else MsgBox "一致項目がありません。" End If End Sub （許斐） ---- ＞の実行釦が有る状態ですよね？ 　あります。 全部のボタン ーーーーーーーーーーーーーーーーーーーーー Private Sub 削除_Click() Call 行削除 End Sub ーーーーーーーーーーーーーーーーーーーーーーーー Private Sub 値クリア_Click() Call 値をクリア End Sub ーーーーーーーーーーーーーーーーーーーーーーーーーー Private Sub 登録_Click() Dim msg As String '氏名と職員番号チェック If Range("B5").Value = "" Then msg = vbLf & "氏名を入力してください。" End If If Range("E4").Value = "" Then msg = msg & vbLf & "職員番号を入力してください。" End If If Len(msg) Then MsgBox msg Exit Sub End If Call 登録修正 Call 値をクリア MsgBox "処理終了しました。" End Sub ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$E$4" Then Exit Sub Call 呼出 End Sub ーーーーーーーーーーーーーーーーーーーーーーーーーーーー Sub 登録修正() Dim mr As Long Dim i As Long, ii As Long, cn As Long Dim kk '重複職員NOチェック With Sheets("貸出") kk = Application.Match(Range("E4").Value, .Range("A:A"), 0) If IsNumeric(kk) Then MsgBox kk & "行目に重複の職員番号がありました（被服貸与）。データを上書きします。" mr = kk Else '↓ダブりがないときの処理 MsgBox "被服貸与該当するデータがありません。新規登録します。" mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 '上の行の書式を下の行にコピー .Range("A" & mr - 1).EntireRow.Copy .Range("A" & mr) .Range("A" & mr).EntireRow.ClearContents '上の行の数式を下の行にコピー .Range("E" & mr - 1).Copy .Range("E" & mr) .Range("G" & mr - 1).Copy .Range("G" & mr) End If .Cells(mr, 1).Value = Range("E4").Value '職員番号 .Cells(mr, 2).Value = Range("B5").Value '氏名 .Cells(mr, 3).Value = Range("B4").Value 'ふりがな .Cells(mr, 4).Value = Range("E5").Value '生年月日 .Cells(mr, 6).Value = Range("H5").Value '採用年月日 .Cells(mr, 8).Value = Range("H4").Value '階級 .Cells(mr, 9).Value = Range("J4").Value '所属 cn = 9 '9行目〜の設定 For i = 7 To 18 '行番頭 i = 1 For ii = 2 To 4 '列番号 cn = cn + 1 .Cells(mr, cn).Value = Cells(i, ii).Value Next Next For i = 7 To 17 '行番号 i = 1 For ii = 6 To 8 '列番号 cn = cn + 1 .Cells(mr, cn).Value = Cells(i, ii).Value Next Next For i = 7 To 18 '行番号 i = 1 For ii = 10 To 12 '列番号 cn = cn + 1 .Cells(mr, cn).Value = Cells(i, ii).Value Next Next .Cells(mr, 115).Value = Range("F18").Value '備考 End With 'サイズ With Sheets("サイズ") kk = Application.Match(Range("E4").Value, .Range("A:A"), 0) If IsNumeric(kk) Then MsgBox kk & "行目に重複の職員番号がありました（採寸表）。データを上書きします。" mr = kk Else '↓ダブりがないときの処理 MsgBox "採寸表に該当するデータがありません。新規登録します。" mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 .Range("A" & mr - 1).EntireRow.Copy .Range("A" & mr) .Range("A" & mr).EntireRow.ClearContents End If .Cells(mr, 1).Value = Range("E4").Value '職員番号 .Cells(mr, 2).Value = Range("B5").Value '氏名 .Cells(mr, 3).Value = Range("B4").Value 'ふりがな For i = 1 To 5 '頭,首,胸囲 .Cells(mr, i + 3).Value = Range("B" & i + 20).Value Next For i = 1 To 4 'ｷｬｯﾌﾟ,シャツ,上着,ズボン .Cells(mr, i + 8).Value = Range("D" & i + 20).Value .Cells(mr, i + 12).Value = Range("F" & i + 20).Value .Cells(mr, i + 16).Value = Range("H" & i + 20).Value Next .Cells(mr, 21).Value = Range("D25").Value End With End Sub ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー Sub 値をクリア() '氏名等 Range("B4:C5,E5:F5,H4,H5:I5,J4").ClearContents '貸し出し Range("B7:D18,F7:H18,J7:L18").ClearContents 'サイズ Range("B21:B25,D21:D24,F21:F24,H21:H24,D25:H25").ClearContents End Sub （許斐） ---- Private Sub 値クリア_Click() Private Sub 登録_Click() のボタンを押すと 「Sub 値をクリア()」が実行されると思いますが この時に、チェンジイベントが実行されて居ませんか？ (HANA) ---- ＞チェンジイベントが実行されて居ませんか？ 　例えばどんなかんじですか？エラー等は起こっていません。。。？？ (許斐） ---- あ！自動呼出しですか？ はいされています。番号がないときは「新規データです。」表示されました。 毎回番号をチェックしてくれます。 （許斐） ---- チェックしてくれなくて良いんですよね？ ＞念のため、全てのコードの先頭にブレークポイントを設定し ＞思いがけない所で実行されていないかも ＞確認して頂ければと思います。 ってのは、そう言う事だったのですが。。。 (HANA) ---- ＞チェックしてくれなくて良いんですよね？ 　毎回番号チェックしてほしいです。 番号の有無がすぐわかるので。。。 （許斐） 　 ---- ん？ Private Sub 値クリア_Click() Private Sub 登録_Click() を実行して Sub 値をクリア()が実行された時の話しですよ？ 誰かがB4セルに値を入力或いは削除 した時ではなく。 ＞＞「Sub 値をクリア()」が実行されると思いますが ＞＞この時に、チェンジイベントが実行されて居ませんか？ ＞はいされています。 ですよね？ (HANA) ---- ＞Private Sub 値クリア_Click() ＞Private Sub 登録_Click() 　のボタンをクリックした後 　→　Private Sub Worksheet_Change(ByVal Target As Range) 　実行されていないか？ 　ていうことですか？ 　実行されません。 意味をくみ違いしていますか？ （許斐） ---- ＞　実行されていないか？ ＞　ていうことですか？ はい、その確認でした。 ＞　実行されません。 ・・・ですね。 失礼しました。 じゃあこっちはこれで終わりで良いんですね。 あ、一つ忘れてました。 もしも　何かの問題が起きて 「Application.EnableEvents = False」 のままでコードが終了して仕舞ったら そのままではイベントが発生しなくなります。 E4セルの値を変更しても コードが実行されないようなら 「Application.EnableEvents = True」 を実行するようにして下さい。 もしかしたら「呼出」のコードの Application.EnableEvents = False '◆イベント無効 この行を Call 値をクリア の下に移動させて 「値をクリア」の中に Application.EnableEvents = True を組み込んでおくのが良いかもしれません。 すると、 「E4の値を変えても変化しなくなったら 　【値クリア】でリセットしてみて」 って言えば良くなるので。 で。。。検索って言うのは。。。 Range("B1").Value の後ろに無条件で「*」をくっつけて こんな感じじゃ上手く行かないですか？ mr = Application.Match(Range("B1").Value & "*", Range("2:2"), 0) (HANA) ---- HANA さん ＞mr = Application.Match(Range("B1").Value & "*", Range("2:2"), 0) 　無事に検索できました。 長々と親切にご指導ありがとうございます。m(＿ ＿)m おかげさまでいいものが完成しました。 本当にありがとうございます。　（☆▽☆） （許斐） ---- 出来ましたか、良かったです。 ＞・・・を組み込んでおくのが良いかもしれません。 と書きましたが、変更しておいて下さい。 （と書いておきます。） (HANA) ---- こうですか？？ On Error GoTo Err '● '===E4以外の値削除=== kv = Range("E4").Value Call 値をクリア Application.EnableEvents = False　　←ここ？？ Range("E4").Value = kv ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー Sub 値をクリア() '氏名等 Range("B4:C5,E5:F5,H4,H5:I5,J4").ClearContents '貸し出し Range("B7:D18,F7:H18,J7:L18").ClearContents 'サイズ Range("B21:B25,D21:D24,F21:F24,H21:H24,D25:H25").ClearContents Application.EnableEvents = True ←ここ？？ End Sub 　（許斐） ---- そうですね。。。 そうしてもらえば、一応動きは問題無いですよね。。。 はっっ、分かりました Private Sub 値クリア_Click() Call 値をクリア Application.EnableEvents = True End Sub こっちへ入れてもらえば良かったです。 そしたら、呼出の方のコードは変更しなくて良いですね。 (HANA) ---- ＞動きは問題無いですよね。。。 　はい確認済みです。 ＞はっっ、分かりました〜+ 　元に戻して 　Private Sub 値クリア_Click()に入れました。 　最後の最後までありがとうございます。m(_ _)m 　（許斐） ---- 後は、運用しながら。。。ですね。 色々問題も出てくるかもしれませんが 頑張って下さい。 (HANA) ---- はい ありがとうございます。 いままで難しいと思った転記方法を要約基礎知識ついた感じです。 また何かありましたら、よろしくお願いします。 許斐