エクセルの学校：全文検索：Hyper Estraier： VBA 強制終了

Results of 1 - 1 of about 85 for VBA 強制終了 (0.004 sec.)

vba (14739), 強制終了 (237)

[[20090914142147]]: #score: 16175; @digest: 30c8ff9c5f311483ca6d93df38475b7b; @id: 45397; @mdate: 2009-09-18T07:22:42Z; @size: 62744; @type: text/plain; #keywords: 服貸 (166939), 許斐 (151532), 被服 (151429), 号cn (149255), 貸与 (131198), 与") (102835), ーー (74854), 斐） (74705), mr (49644), 貸出 (43790), 職員 (42583), 呼出 (30917), 員番 (28805), value (13481), isnumeric (11325), range (10448), 登録 (10347), cells (9717), 番号 (9440), 列番 (9156), 行番 (9111), リア (8980), イズ (6636), application (6187), 氏名 (5810), クリ (5674), 。" (5671), hana (5118), match (5048), 転記 (4880), 新規 (4497), サイ (4427); 『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 の番号が入っていますがこの名前は、MaxRow番号と言った感じです。 MATCH関数の戻り値（行番号）は、kk に入れました。実際は、見つからなかった時にエラー値も入りますが。。。この名前は、KensakuKekka で、kkにしてあります。変数名は好きな名前を付ければ良いので後で見た時に分かりやすい物にしておくのが良いと思います。細かい事ですが、mr の由来は上記ですので mr って変数名なのに最大行数が入っていないまま他の部分で使ってあると、mr の名が廃ると言うか「じゃあ、mrじゃ無くて良いじゃん」とか思って仕舞います。もしも、Move-Row とかだったら 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) ---- はいありがとうございます。いままで難しいと思った転記方法を要約基礎知識ついた感じです。また何かありましたら、よろしくお願いします。許斐 ...; https://www.excel.studio-kazu.jp/wiki/kazuwiki/200909/20090914142147.txt - [detail] - similar

PREV NEXT

訪問者：カウンタ