『実行時ｴﾗｰ１３　型が一致しません　と…』　（ゆき）

[[20100826182137]] で 大変に大変に　お世話になりました　ありがとうございましたm(__)m
 すみません　入力していってみたら　教えてもらう前に作っていたシートから　
 今回新しく 教えてもらったシートに写そうと　今　コピーして貼り付けして　直していた所なのですが
 
 昔作っていたF列に　入れてあるものを　まとめてコピーして（F4：F80位まで）　新しく作ったF列に　それを　貼り付けをすると
 
 実行時エラー１３　型が一致しません　と出て　デバック　を押すと
 マクロの　　　If .Value = "" Then　という所が黄色くなっています
 
 F列に　一つずつ言葉を　ガソリン　とか入れていくには　きちんと教えて頂いたマクロの通りになるのですが
 何行かを　まとめてコピーしたものを　貼り付けると　このエラーが出てきます
 やはり　一行ずつ　入力していく方法しかないという事になりますでしょうか？

 すみません　m(__)m　宜しくお願い致します　m(__)m
 
----
 おはようございます。
 私の書いたコードは複数セルのコピペにも対応してます。
 （ウッシ）
----
 ウッシさんのコードもやってみてくださいね。。
 
 わたしの場合ですと、
 シートタブ→右クリック→コードの表示で、
 そのにあるコードに下記のコードを張り付けてみて。コードの差し替えです。

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Integer, j As Integer, k As Integer

    Application.EnableEvents = False
    If Not Intersect(Target, Range("F:F")) Is Nothing Then
        Application.EnableEvents = False
        Me.Unprotect
        For Each Target In Selection
            With Target
                If .Value = "" Then
                    With .Offset(, 1)
                        .Value = ""
                        .Interior.ColorIndex = xlNone
                        .Font.ColorIndex = 0
                    End With
                Else
                    k = WorksheetFunction.CountIf(Sheets("Sheet2").Range("A:A"), Target.Value)
                    If k = 1 Then
                        j = WorksheetFunction.Match(Target.Value, Sheets("Sheet2").Range("A:A"), 0)
                        Sheets("Sheet2").Cells(j, 2).Copy Target.Offset(, 1)
                    Else
                        j = WorksheetFunction.Match("その他出費", Sheets("Sheet2").Range("B:B"), 0)
                        Sheets("Sheet2").Cells(j, 2).Copy Target.Offset(, 1)
                    End If
                End If
            End With
        Next Target
        Me.Protect
        Application.EnableEvents = True
    End If
 End Sub
 そっかー、このような事も想定しなくっちゃ ^^;
 ちょこっと訂正しました。9:35 8/31
 (kei)
----
 （ゆき）ウッシさん keiさん　ありごとうございます
 ウッシさんのを　やってみたら　すみません(~_~;)
 名前が適切ではありません
 jyunbbi　　
 とエラーが出て　OK　とヘルプ　と出て　Sub jyunbbi　の所が青くなっていました
 すみません　(-_-;)　うまくいかず　すみません　(-_-;)
 それと　keiさん　すみません　この間のコタさんのを消してから　上のを貼り付けてやったら
 色も言葉も出てこず(~_~;)　
 何故か　F4に電話代と入れたらG４は　通信費　に変換されず 色も変わらず、G4は何も変化せず
 隣のH4に元々　黄色が入れてあるのですが H4が　パッと　色がなくなります　すいません…　(-_-;)
 
 それで　もしかして下に貼り付けるのかなと思いまして
 この前の　コタさんのマクロの下に貼り付けたら
 ｺﾝﾊﾟｲﾙｴﾗｰ　名前が適切ではありません　と出て
 Private Sub Worksheet_Change(ByVal Target As Range　の所が青くなっています　(-_-;)

 すみません私　またまた何が間違っていますでしょうか　m(__)m
 宜しくお願い致します　m(__)m


 

----
 こんにちは
 
 「jyunbbi」が二つあると思う思うので削除して下さい。

 あと、まだ保護はしたままなのですか？
 してあるなら、こちらに差し替えて下さい。

 Sub jyunbbi()
    Application.EnableEvents = False
    With Worksheets("収支表").Range("G:G")
        .Parent.Unprotect
        .Value = .Value
        .Parent.Protect
    End With
    Application.EnableEvents = True
End Sub
 
 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim j As Variant
    Dim r As Range
    Dim t As Range

    Set t = Intersect(Target, Range("F:F"))
    If t Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Me.Unprotect
    For Each r In t
        With r
            If .Value = "" Then
                With .Offset(, 1)
                    .Value = ""
                    .Interior.ColorIndex = xlNone
                    .Font.ColorIndex = 0
                End With
            Else
                j = Application.Match(.Value, Sheets("Sheet2").Range("A:A"), 0)
                If IsError(j) Then
                    j = Application.Match("それ以外", Sheets("Sheet2").Range("A:A"), 0)
                End If
                Sheets("Sheet2").Cells(j, 2).Copy Target.Offset(, 1)
            End If
        End With
    Next
    Me.Protect
    Application.EnableEvents = True
End Sub


 「エラーで終了した時」は何らかの原因でイベントマクロを中断終了した時に実行して下さい。

 Sub エラーで終了した時()
    Application.EnableEvents = True
End Sub

 （ウッシ）
----
 ウッシさんと、わたしので混乱させちゃいますね。^^;

 とりあえず、二人のブックを別々にしておいて検証してみて。
 わたしの場合ですと、
 「収支表シート」のシートタブ→右クリック→コードの表示で、
 そのにあるコードを一度全部消してから、下記のコードを張り付けてみて。

 もし、なにも変化がなく「おかしー?」と思ったら、
 最後に書いてある（ウッシさんのをパクッたもの m(__)m）で、「動かないときに使う」マクロを実行してネ。
　
   ↓ココから
  Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Integer, j As Integer, k As Integer

    If Not Intersect(Target, Range("F:F")) Is Nothing Then
        Application.EnableEvents = False
        Me.Unprotect
        For Each Target In Selection
            With Target
                If .Value = "" Then
                    With .Offset(, 1)
                        .Value = ""
                        .Interior.ColorIndex = xlNone
                        .Font.ColorIndex = 0
                    End With
                Else
                    k = WorksheetFunction.CountIf(Sheets("Sheet2").Range("A:A"), Target.Value)
                    If k = 1 Then
                        j = WorksheetFunction.Match(Target.Value, Sheets("Sheet2").Range("A:A"), 0)
                        Sheets("Sheet2").Cells(j, 2).Copy Target.Offset(, 1)
                    Else
                        j = WorksheetFunction.Match("その他出費", Sheets("Sheet2").Range("B:B"), 0)
                        Sheets("Sheet2").Cells(j, 2).Copy Target.Offset(, 1)
                    End If
                End If
            End With
        Next Target
        Me.Protect
        Application.EnableEvents = True
    End If
 End Sub

 Sub 動かないときに使う()
    Application.EnableEvents = True
 End Sub
     ↑ココまで
 (kei)
----
余計なお世話かもしれませんが、こうしといてあげたらどうでしょう？

 Private Sub Worksheet_Change(ByVal Target As Range)
 On Error GoTo Exit_sub
 '
 '処理
 '
 Exit_sub:
     MsgBox Err.Number & vbNewLine & Err.Description
     Application.EnableEvents = True
 End Sub

（ramrun）
----
 こんにちは
 最終的にはそうするといいんですけど、エラーが出るうちはどこで止まったか教えて欲しいので。
 （ウッシ）
----
 ウッシさん、なるほどです。。m(__)m

 ramrunさん、こんにちわ。。
 こんな方法があるのですね・・わたくし「一つ進化しました」デヘヘ ^^
 ゆきさん、またまたコードの差し替えです。m(__)m
 前のに上書きしてネ。

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Integer, j As Integer, k As Integer
    
    On Error GoTo Exit_sub
    If Not Intersect(Target, Range("F:F")) Is Nothing Then
        Application.EnableEvents = False
        Me.Unprotect
        For Each Target In Selection
            With Target
                If .Value = "" Then
                    With .Offset(, 1)
                        .Value = ""
                        .Interior.ColorIndex = xlNone
                        .Font.ColorIndex = 0
                    End With
                Else
                    k = WorksheetFunction.CountIf(Sheets("Sheet2").Range("A:A"), Target.Value)
                    If k = 1 Then
                        j = WorksheetFunction.Match(Target.Value, Sheets("Sheet2").Range("A:A"), 0)
                        Sheets("Sheet2").Cells(j, 2).Copy Target.Offset(, 1)
                    Else
                        j = WorksheetFunction.Match("その他出費", Sheets("Sheet2").Range("B:B"), 0)
                        Sheets("Sheet2").Cells(j, 2).Copy Target.Offset(, 1)
                    End If
                End If
            End With
         Next Target
         Me.Protect
         Application.EnableEvents = True
    End If
    Exit Sub
 Exit_sub:
     MsgBox Err.Number & vbNewLine & Err.Description
     Application.EnableEvents = True
 End Sub
 (kei) 
----
ウッシさん、言われてみればそのとおりですね（汗）。

無理やり使うなら、あらかじめ行番号を振っておくという方法もあるようです。

 Private Sub Worksheet_Change(ByVal Target As Range)
 1 On Error GoTo Exit_sub
 2 '
 3 '処理
 4 '

 Exit_sub:
     MsgBox Err.Number & vbNewLine & Err.Description & vbNewLine & Erl
     Application.EnableEvents = True
 End Sub

（ramrun）
----
（ゆき）
 難しくなってきて　頭が(~_~;)ついていけない…(~_~;)　すみません
 ます　keiさんの上のマクロと　2番目のマクロを
 収支表だった　シートに　貼り付けましたが　今は名前を　1　にしました
 なぜなら1月〜12月の同じシートが12枚あるので　1月なので　1　にしました
 そして　F4に　ガソリンと入れたら　ｺﾝﾊﾟｲﾙｴﾗｰ　名前が適切ではありません
 と出て　OKで閉じると
 Private Sub Worksheet_Change(ByVal Target As Range　は青くなっています
 すみません　(~_~;)
 
 それと　ウッシさんの
 ＞「エラーで終了した時」は何らかの原因でイベントマクロを中断終了した時に実行して下さい。

 Sub エラーで終了した時()
    Application.EnableEvents = True
End Sub

 と書いてある意味が判らず…(~_~;)　すみません　エラーが出て中断してしまった時に　どうやったらいいでしょうか　

 と同じく　keiさんの
 ＞もし、なにも変化がなく「おかしー?」と思ったら、
 最後に書いてある（ウッシさんのをパクッたもの m(__)m）で、「動かないときに使う」マクロを実行してネ。

 の意味も判らず…　本当にごめんなさい　皆さんがせっかく教えて下さっているのに
 申し訳ないです　(-_-;)　判らないです　(-_-;)
 　
 それとウッシさん
 保護はこの間の最後にコタさんが　作って下さったのが　打ち終わったら　自然に保護がかかるようになっていたので
 保護はしていないです
 とすると
 ＞「jyunbbi」が二つあると思う思うので削除して下さい
 
　はせずに　このマクロのを入れてみればいいでしょうか
 すみません　つまり

 Sub jyunbbi()
    Application.EnableEvents = False
    With Worksheets("収支表").Range("G:G")
        .Parent.Unprotect
        .Value = .Value
        .Parent.Protect
    End With
    Application.EnableEvents = True
End Sub

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim j As Variant
    Dim r As Range
    Dim t As Range

    Set t = Intersect(Target, Range("F:F"))
    If t Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Me.Unprotect
    For Each r In t
        With r
            If .Value = "" Then
                With .Offset(, 1)
                    .Value = ""
                    .Interior.ColorIndex = xlNone
                    .Font.ColorIndex = 0
                End With
            Else
                j = Application.Match(.Value, Sheets("Sheet2").Range("A:A"), 0)
                If IsError(j) Then
                    j = Application.Match("それ以外", Sheets("Sheet2").Range("A:A"), 0)
                End If
                Sheets("Sheet2").Cells(j, 2).Copy Target.Offset(, 1)
            End If
        End With
    Next
    Me.Protect
    Application.EnableEvents = True
End Sub


 「エラーで終了した時」は何らかの原因でイベントマクロを中断終了した時に実行して下さい。

 Sub エラーで終了した時()
    Application.EnableEvents = True
End Sub

 と↑ここまでを入れて　それで　ramrunさんの
 
 Private Sub Worksheet_Change(ByVal Target As Range)
 1 On Error GoTo Exit_sub
 2 '
 3 '処理
 4 '

 Exit_sub:
     MsgBox Err.Number & vbNewLine & Err.Description & vbNewLine & Erl
     Application.EnableEvents = True
 End Sub

 を　ウッシさんの　下に続けて入れる？でしょうか？(^_^;)
 何か　皆さんの知識が凄すぎて m(__)m　私との差が凄いので　目玉が落ちそうです　(~_~;)

 すみません　私のしている事が　おかしすぎると思いますが　宜しくお願い致します　m(__)m　
 
----
 ゆきさん、ガンバ!!
 仕事で楽をするために、あと一頑張りよ! 楽しなくっちゃ!^^

 ウッシさんとわたしのブックを別にしておいてね。わけが分かんなくなるから。。

 シート名を1月なので、「1」にしても問題ありません。
 もう一度、最初からゆっくりやってみて、、

 [1」そのシートのシートタブ→右クリック→コードの表示で、
 そこにあるコードを一度全部消してから、下記のコードを張り付けてみて。
                      ^^^^^^^^^^^^^^^   ^^^^^^^^^^^^^^^^^^^^^
 ただそれだけです。。

   ↓ココから
 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Integer, j As Integer, k As Integer

    On Error GoTo Exit_sub
    If Not Intersect(Target, Range("F:F")) Is Nothing Then
        Application.EnableEvents = False
        Me.Unprotect
        For Each Target In Selection
            With Target
                If .Value = "" Then
                    With .Offset(, 1)
                        .Value = ""
                        .Interior.ColorIndex = xlNone
                        .Font.ColorIndex = 0
                    End With
                Else
                    k = WorksheetFunction.CountIf(Sheets("Sheet2").Range("A:A"), Target.Value)
                    If k = 1 Then
                        j = WorksheetFunction.Match(Target.Value, Sheets("Sheet2").Range("A:A"), 0)
                        Sheets("Sheet2").Cells(j, 2).Copy Target.Offset(, 1)
                    Else
                        j = WorksheetFunction.Match("その他出費", Sheets("Sheet2").Range("B:B"), 0)
                        Sheets("Sheet2").Cells(j, 2).Copy Target.Offset(, 1)
                    End If
                End If
            End With
         Next Target
         Me.Protect
         Application.EnableEvents = True
    End If
    Exit Sub
 Exit_sub:
     MsgBox Err.Number & vbNewLine & Err.Description
     Application.EnableEvents = True
 End Sub
      ↑ココまで

 「おかしー?」と思ったら、「動かないときに使う」マクロは、もう必要ありません。。
 (kei)
----
 こんばんは

 みんなのコードを一つのブックにセットしてはダメですよ。
 私のコードは ゆき さんが作ったブックを使いたいという要望が有ったので
 >「最初に私が作ったもの」のコピーブックで試して下さい。
 とお断りしたはずです。

  Sub jyunbbi()
    Application.EnableEvents = False
    With Worksheets("収支表").Range("G:G")
        .Parent.Unprotect
        .Value = .Value
        .Parent.Protect
    End With
    Application.EnableEvents = True
End Sub

 この「jyunbbi」は収支表シートのG列にVLookup の式が残っていたら値に変換します。
 コードの中をクリックして、F5キーを押せば実行されます。

 その後に、収支表シートのシートモジュールに下記コードを貼り付ければ終わりです。

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim j As Variant
    Dim r As Range
    Dim t As Range

    Set t = Intersect(Target, Range("F:F"))
    If t Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Me.Unprotect
    For Each r In t
        With r
            If .Value = "" Then
                With .Offset(, 1)
                    .Value = ""
                    .Interior.ColorIndex = xlNone
                    .Font.ColorIndex = 0
                End With
            Else
                j = Application.Match(.Value, Sheets("Sheet2").Range("A:A"), 0)
                If IsError(j) Then
                    j = Application.Match("それ以外", Sheets("Sheet2").Range("A:A"), 0)
                End If
                Sheets("Sheet2").Cells(j, 2).Copy Target.Offset(, 1)
            End If
        End With
    Next
    Me.Protect
    Application.EnableEvents = True
End Sub

 （ウッシ）
----
私のは下に続けて入れちゃだめですよ（汗）。

Private Sub Worksheet_Change() 〜 End Sub はセルで変更があったりすると勝手に実行されるんですが、こういうのをイベントといいます。

Private Sub Worksheet_Change() 〜 End Sub の中でセルを操作すると、またPrivate Sub Worksheet_Change() 〜 End Sub が実行されて、その処理の中でセルを操作すると...　と永遠に繰り返しとなってしまうのはわかるでしょうか？

そこでセルを操作するところの前で Application.EnableEvents = False 、要するにイベントを無効にしておいて、セルの操作が終わったら Application.EnableEvents = True で有効に戻すというコードになっています。

ところがセルを操作している途中でエラーになって終了してしまうと、End Sub 手前にあるApplication.EnableEvents = True を実行せずに終わってしまい...

すると、次に試そうとしたときにはPrivate Sub Worksheet_Change() 〜 End Subが実行されない（無反応）なので、

 Sub エラーで終了した時()
    Application.EnableEvents = True
 End Sub

を実行してみて〜　ということなんですが、私のは「エラーになったら Application.EnableEvents = True になるようにしといてあげたら？」という意味になります。

ただこれをやると、どの行でエラーになったかがわからない〜　というのが ウッシさん意見で、要するに長くなりましたが『やらなくてよい』ということです。

（ramrun）長々書いてたら衝突〜
----
 ramrunさん、ありがとうございました。
 未熟なわたしには、すばらしい「ツール」でした。
 また教えてくださいネ ^^v
 お仕事に真面目な(kei)
----
（ゆき）
 keiさん　すいません(-_-;)　1　のシートを右クリックしてコードを表示して、この間のを全て青くして選択してバックスペースで消して　
 そこに 上のkeiさんのを貼り付けて　バツで閉じて　1　というシートに戻り、
 F４に電話代と打つと Ｇ４　は何も変化せず　(~_~;)　
 その隣のＨ４に元々　黄色が入れてあるのですが その色が　パッと　消えます　すいません…　(-_-;)
 色の設定を入れてあるsheet2 は一番最初に教えて頂いた数式はもう消していますが　いいですよね　
 う〜ん　何で　出来ないでしょう　何が違うんだろう。。。おかしいなーーー(-_-;)
 次に　ウッシさんのを　ちょっと　チョコレートでも食べて　頭を切り替えて
 やってみます　すいません　m(__)m


----
 ゆきさん、チョコレートいいなぁ!!
 数式は消しちゃって良いですよ。
 一度そのブックを保存して、エクセルを終了させて、もう一度立ち上げてから入力してみて。。
 明日の夜は、浴びるほどビールを飲むゾ(kei)
----
（ゆき）　
 ウッシさんのをやってみたら　F4に電話代　と入れたらG4は綺麗に　通信費　と出て　色も変わりました　その他出費　も出ました　
 1個ずつ入力していくのは成功しました　　
 それで　よし！！と思って、過去に作ってあった　別のブックの　ガソリン代とか　電話代とかの いろんなものが打ってあったシートの 
 F4:F77を　コピーして この度のF4:F77に まとめて貼り付けましたら　パッパッパッパッパッと　

 何回も　G4:G77が つまり sheet2のB列 に入れてある 順番なのか いろんな項目のいろんな色に
 G4:G77まで　まとめてですが　最初は　通信費の緑のセル　となって　
 それがG4:G77 の上から下まで　全部が　パッパッパッパッパッ　と　手品のように変わっていきまして
 通信費の次は　雑費の赤　次は　交際費のピンク…
 と何回も G4:G77の上から下までまとめて　同じものに次々と変わり続け
 そして　どうなるのかと観察していましたら　最後は　sheet2のB列の105：111　を入院保険にしていたのですが
 入院保険　でブルーに G4:G77　全部が　入院保険になりました
 sheet2　は　AとBの列は　ずっと入力していったら　今の段階では119行目になりましたが
 これからも　どんどん増えそうですが　これは何行目まで　増えても　関係ないですか？　
 大変すみません　何が私おかしいでしょうかm(__)m　すみませんが何卒宜しくお願い致します　m(__)m
----
 こんにちは

 済みません、一箇所、間違えてました。

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim j As Variant
    Dim r As Range
    Dim t As Range
    
    Set t = Intersect(Target, Range("F:F"))
    If t Is Nothing Then Exit Sub
    Application.EnableEvents = False
    For Each r In t
        With r
            If .Value = "" Then
                With .Offset(, 1)
                    .Value = ""
                    .Interior.ColorIndex = xlNone
                    .Font.ColorIndex = 0
                End With
            Else
                j = Application.Match(.Value, Sheets("Sheet2").Range("A:A"), 0)
                If IsError(j) Then
                    j = Application.Match("それ以外", Sheets("Sheet2").Range("A:A"), 0)
                End If
                Sheets("Sheet2").Cells(j, 2).Copy .Offset(, 1)
            End If
        End With
    Next
    Application.EnableEvents = True
End Sub

 差し替えて下さい。

 （ウッシ）
----
（ゆき）ウッシさん　お返事遅くなりました　すいませんでした
 出来ました　ありがとうございます　
 最初にテスト入力してみたら、綺麗に昔のものが　まとめて貼り付けれました
 しかし　ひとつでも　F　を消すと、例えばF15とかを　消してみると
 interior ｸﾗｽのcolirindexﾌﾟﾛﾊﾟﾃｨを設定できません　と出て　ﾃﾞﾊﾞｯｸの所を押すと
 Interior.color Index=XINone の所が　黄色くなっていたので　
 あれ　又保護がかかったかなと 見てみたら　保護が自然に　かかっていました(^_^;)
 
 なので　又最初から新しいのを作り直して調べましたら　マクロのコードを　入れると　保護が　自然にかかって
 後から　Fの修正をしたりすると　上のエラーが出てしまいます　(^_^;)すみません
 
 F列の例えば　F15　を削除する前に　保護を外すしてから　F15を削除すると
 エラーが出ずに 綺麗に出来ます　すみません　何が間違っていますでしょうか(~_~;)
 本当に　すみません　m(__)m
 宜しくお願い致します　m(__)m
----
 こんばんは
 また保護を付け外しする前のコード直してました。
 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim j As Variant
    Dim r As Range
    Dim t As Range

    Set t = Intersect(Target, Range("F:F"))
    If t Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Me.Unprotect
    For Each r In t
        With r
            If .Value = "" Then
                With .Offset(, 1)
                    .Value = ""
                    .Interior.ColorIndex = xlNone
                    .Font.ColorIndex = 0
                End With
            Else
                j = Application.Match(.Value, Sheets("Sheet2").Range("A:A"), 0)
                If IsError(j) Then
                    j = Application.Match("それ以外", Sheets("Sheet2").Range("A:A"), 0)
                End If
                Sheets("Sheet2").Cells(j, 2).Copy .Offset(, 1)
            End If
        End With
    Next
    Me.Protect
    Application.EnableEvents = True
End Sub

 コード差し替えて一旦ブックを保存終了するか、
 Sub エラーで終了した時()
    Application.EnableEvents = True
 End Sub
 を標準モジュールに入れて、コードの中をクリックしてからF5キーで実行して下さい。
 エラーで中断終了したままだとイベントが発生しないと思いますので。

 （ウッシ）
----
（ゆき）
 ウッシさん　凄いです　出来ました！！
 すみません　確認させておいてください。
 一番上で教えて頂いた
 Sub jyunbbi()
    Application.EnableEvents = False
    With Worksheets("収支表").Range("G:G")
        .Parent.Unprotect
        .Value = .Value
        .Parent.Protect
    End With
    Application.EnableEvents = True
End Sub

 は入れずに
 結局　入れるのは
 
 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim j As Variant
    Dim r As Range
    Dim t As Range

    Set t = Intersect(Target, Range("F:F"))
    If t Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Me.Unprotect
    For Each r In t
        With r
            If .Value = "" Then
                With .Offset(, 1)
                    .Value = ""
                    .Interior.ColorIndex = xlNone
                    .Font.ColorIndex = 0
                End With
            Else
                j = Application.Match(.Value, Sheets("Sheet2").Range("A:A"), 0)
                If IsError(j) Then
                    j = Application.Match("それ以外", Sheets("Sheet2").Range("A:A"), 0)
                End If
                Sheets("Sheet2").Cells(j, 2).Copy .Offset(, 1)
            End If
        End With
    Next
    Me.Protect
    Application.EnableEvents = True
End Sub

 ↑ここまでを入れておいてから　挿入→標準モジュール　で
 そこに
 Sub エラーで終了した時()
    Application.EnableEvents = True
 End Sub

 を入れて　F5を押す

 で　いいでしょうか？　すみません　宜しくお願い致します　m(__)m
----
 おはようございます。

 Sub jyunbbi() はG列にVLookup 等の計算式が残っている場合に実行します。
 何も式がセットされていなければ実行する必要は無いです。

 Sub エラーで終了した時() は  Private Sub Worksheet_Change(ByVal Target As Range)
 が何らかの原因で中断し、そのまま終了させた時に実行します。
 その際にコードのどこで中断したか、どんなエラーメッセージか記録しておけば再質問する時に役立つ情報になります。

 （ウッシ）


----
 みなさん、おはよーございます。
 ゆきさん、出来たようですね。良かった ^^
 昨夜は酔いつぶれていました。。
 (kei)
----
（ゆき）ウッシさん　ありごうとございました。一枚　打ち終わってから　F５とかを
 削除しても　エラーは出なくなり　綺麗に出来るようになりました (^_^)
 ありがとうございます　m(__)m　
 それで　一つ聞きたいのですが　打ち終わってから
 削除して　次に　上の矢印の「元に戻る　」　を押そうと思っても　グレーになっていて押せないのは
 元に戻る　ボタンは　効かない？という事になりますでしょうか？
 すみませんが　教えて下さい　宜しくお願い致します　m(__)m
----
 こんばんは
 このようなイベントマクロの場合、一旦処理が走ると「元に戻る」事は出来ません。
 セルをクリアする場合は本当にクリアして良いかメッセージを出すとこんな感じです。

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim j As Variant
    Dim r As Range
    Dim t As Range

    Set t = Intersect(Target, Range("F:F"))
    If t Is Nothing Then Exit Sub
    If WorksheetFunction.CountBlank(t) > 0 Then
        If MsgBox("F列のセルがクリアされます。宜しいですか？", 49) = vbCancel Then
            Application.EnableEvents = False
            Me.Unprotect
            Application.Undo
            Me.Protect
            Application.EnableEvents = True
            Exit Sub
        End If
    End If
    Application.EnableEvents = False
    Me.Unprotect
    For Each r In t
        With r
            If .Value = "" Then
                With .Offset(, 1)
                    .Value = ""
                    .Interior.ColorIndex = xlNone
                    .Font.ColorIndex = 0
                End With
            Else
                j = Application.Match(.Value, Sheets("Sheet2").Range("A:A"), 0)
                If IsError(j) Then
                    j = Application.Match("それ以外", Sheets("Sheet2").Range("A:A"), 0)
                End If
                Sheets("Sheet2").Cells(j, 2).Copy .Offset(, 1)
            End If
        End With
    Next
    Columns("F:F").Locked = False
    Me.Protect
    Application.EnableEvents = True
End Sub

 （ウッシ）
----
（ゆき）
 ウッシさん　ありがとうございました。元に戻れない　警告みたいなのが出るんですね〜〜　凄いですねーー。
 ウッシさん　本当にお世話になり　どうも　ありがとうございました(^_^)
 keiさん　ramrunさんにも　大変にお世話になりました　m(__)m
 ウッシさん　理解力のない私相手に　最後まで教えて頂いて　
 本当に　どうもありがとうございました　m(__)m
----
（ゆき）
 もう見て頂けるか　わかりませんが　
 すみません　ウッシさん上のを入れようと思いますが　そうすると
 
 ＞Sub エラーで終了した時()
    Application.EnableEvents = True
 End Sub
 を標準モジュールに入れて、コードの中をクリックしてからF5キーで実行して下さい

 
 これは　入れておいた方が　いいでしょうか？
----
 おはようございます。
 別のブックにしたのなら入れておいて下さい。
 大体のエラーを本コードで回避出来るようになったら、keiさんのコードにあったように
 On Error GoTo Exit_sub 
 〜  
     Exit Sub
Exit_sub:
     MsgBox Err.Number & vbNewLine & Err.Description
     Application.EnableEvents = True
End Sub
 を本コードに入れてあげるといいです。

 （ウッシ）

----
（ゆき）ウッシさん　ありがとうございましたm(__)m

 ＞大体のエラーを本コードで回避出来るようになったら、keiさんのコードにあったように
 On Error GoTo Exit_sub 
 〜  
     Exit Sub
Exit_sub:
     MsgBox Err.Number & vbNewLine & Err.Description
     Application.EnableEvents = True
End Sub
 を本コードに入れてあげるといいです

 

 の意味が　すみません　判らないのですが(^_^;)
 という事は　

  On Error GoTo Exit_sub 
 〜  
     Exit Sub
Exit_sub:
     MsgBox Err.Number & vbNewLine & Err.Description
     Application.EnableEvents = True
End Sub

　を

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim j As Variant
    Dim r As Range
    Dim t As Range

    Set t = Intersect(Target, Range("F:F"))
    If t Is Nothing Then Exit Sub
    If WorksheetFunction.CountBlank(t) > 0 Then
        If MsgBox("F列のセルがクリアされます。宜しいですか？", 49) = vbCancel Then
            Application.EnableEvents = False
            Me.Unprotect
            Application.Undo
            Me.Protect
            Application.EnableEvents = True
            Exit Sub
        End If
    End If
    Application.EnableEvents = False
    Me.Unprotect
    For Each r In t
        With r
            If .Value = "" Then
                With .Offset(, 1)
                    .Value = ""
                    .Interior.ColorIndex = xlNone
                    .Font.ColorIndex = 0
                End With
            Else
                j = Application.Match(.Value, Sheets("Sheet2").Range("A:A"), 0)
                If IsError(j) Then
                    j = Application.Match("それ以外", Sheets("Sheet2").Range("A:A"), 0)
                End If
                Sheets("Sheet2").Cells(j, 2).Copy .Offset(, 1)
            End If
        End With
    Next
    Columns("F:F").Locked = False
    Me.Protect
    Application.EnableEvents = True
End Sub

 の下に　
 On Error GoTo Exit_sub 
 〜  
     Exit Sub
Exit_sub:
     MsgBox Err.Number & vbNewLine & Err.Description
     Application.EnableEvents = True
End Sub

 を貼り付ければいいという事でしょうか？　すみません　宜しくお願い致しますm(__)m
----
 こんにちは
 keiさんのコードを見れば分かると思います。
 そろそろコードを読むようにした方がいいですよ。
 こうしたいというゆきさんの要求を満たすようにコードを書いてるつもりなので、どこが何をしてるコードなのか想像もつくと思うのですが？
 
 分からない部分、例えば「Intersect」とかが有ったら、その単語の部分をクリックして F1キーを押すと
 ヘルプが出ます。（ヘルプがインストールしてなかったらインストールしておいた方がいいです。）

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim j As Variant
    Dim r As Range
    Dim t As Range

    On Error GoTo Exit_sub
    
    Set t = Intersect(Target, Range("F:F"))
    If t Is Nothing Then Exit Sub
    If WorksheetFunction.CountBlank(t) > 0 Then
        If MsgBox("F列のセルがクリアされます。宜しいですか？", 49) = vbCancel Then
            Application.EnableEvents = False
            Me.Unprotect
            Application.Undo
            Me.Protect
            Application.EnableEvents = True
            Exit Sub
        End If
    End If
    Application.EnableEvents = False
    Me.Unprotect
    For Each r In t
        With r
            If .Value = "" Then
                With .Offset(, 1)
                    .Value = ""
                    .Interior.ColorIndex = xlNone
                    .Font.ColorIndex = 0
                End With
            Else
                j = Application.Match(.Value, Sheets("Sheet2").Range("A:A"), 0)
                If IsError(j) Then
                    j = Application.Match("それ以外", Sheets("Sheet2").Range("A:A"), 0)
                End If
                Sheets("Sheet2").Cells(j, 2).Copy .Offset(, 1)
            End If
        End With
    Next
    Columns("F:F").Locked = False
    Me.Protect
    Application.EnableEvents = True
    Exit Sub
Exit_sub:
     MsgBox Err.Number & vbNewLine & Err.Description
     Application.EnableEvents = True
End Sub

 （ウッシ）
----
（ゆき）
 ウッシさん　大変にお世話になりました　本当にありがとうございましたm(__)m
 コードを読む　というのは　私にとって　とても難しい事ですが　努力してみます　m(__)m
 本当にお世話になりました
 ウッシさん　どうもありがとうございました　(*^_^*)