エクセルで自動入力をマクロで・・・（No.1798323の応用編）

質問

応用が効かなくて申し訳ありません。
1798323で素敵なご回答をいただいたのですが、
状況が進展して変わってくるとＶＢＡの書き換えがわからなくなりました。もう一度教えてください。

※変更点は、入力元がAI列、『入力先をＱ～Ｖ列に限定』したい点です。

　　Q 　　　R　　　 S 　　 T 　　U　V・・ AI
1 田中　鈴木　佐藤　　　　　　　　　　山田
2 鈴木　山田 　　　　　　　　　　　　　海岡
3 田中　佐藤 　　　　　　　　　　　　　佐藤

というような表があり、T1に「山田」、S2「海岡」と、その行に関してAI列に新規の名前が入力されたときに自動入力することをVBAでどのように書けばよいのか、ご教授お願いいたします。
尚、3行目には「佐藤」さんがすでいるので入力不要です。
よろしくお願いします。

回答No.13

shiotan99 · ベストアンサー

No.11です。

> 重複チェック時のメッセージボックスが不要である場合、‥

単にメッセージを出さないようにする、っていうことですよね？
てっとり早いのは、

MsgBox myName & "さんは入力済ですよ！", vbInformation
　　↓
Exit Sub

に変えてください。
重複している場合は何もしないで処理を抜ける（ Exit Sub ) ということです。
'----------------------
If WorksheetFunction.CountIf(Range(Cells(.Row, startCol), Cells(.Row, endCol)), myName) > 0 Then
　　Exit Sub
'----------------------
★ ただし↑だけでは、
名前を上書きしようと思って 「３中田」 のように入力したけれど、中田さんはすでに入力済みの場合、入力元には 「３中田」 と数字が残ったままになります。
この数字を消して 「中田」 とだけにしたいなら、
'----------------------
If WorksheetFunction.CountIf(Range(Cells(.Row, startCol), Cells(.Row, endCol)), myName) > 0 Then
　　If myChgFlag Then
　　　　Application.EnableEvents = False
　　　　.Value = myName
　　　　Application.EnableEvents = True
　　End If
'----------------------
としてください。この場合、Exit Sub は不要です。

◆
ついでと言ってはナンですが‥
'---名前上書きのエラーチェック
の下に
myChgFlag = False
myErrFlag = False
の 2行がありますよね。

この 2行は不要といえば不要なんですが、入れるとしたらココではなく、
コードの 14行目
If Not IsNumeric(Left(.Value, 1)) Then
の前でした。
'----------------------
myChgFlag = False
myErrFlag = False
If Not IsNumeric(Left(.Value, 1)) Then
　　myName = .Value
'----------------------
に変更してください。

お礼

ありがとうございます。超初心者にこんなに懇切丁寧にご指導いただきましたことを感激しています。実際、ＶＢＡの可能性とsiotan99さんの力量に驚いています。感謝のことばしかありません。本当にありがとうございました。

回答No.12

kamejiro

＃７です。日数が経ちましたが…。
yastaroさん、最初の頃からみると、かなりの追加仕様ですね。私も頭が悩みます。（若くないので頭の柔軟性がありません。）

＞入力元がAI,AQ,AY・・・、入力先は変わらずQ～Vといった具合…。

この場合、＃７でのプログラムはそのままで、Sheet2を

　　　A　　　　　　　　B
1　入力元列番号　　35　　　…AI列
2　入力元開始行　　1
3　入力元終了行　　13　　　…1行目から13行目
4　入力先開始列　　17
5　入力先終了列　　22　　　…Q列からV列

のように入力し実行します。

入力元をAQ列に換えるときは、B1のセルを「35」から「43」に換えて実行します。

入力元をAY列に換えるときは、B1のセルを「43」から「47」に換えて実行します。

それにしても、shiotan99さん。丁寧な回答には大変参考になります…。入力誤りを訂正するといった応用って…、整合性の取れたロジックを考えつくなんて…。

お礼

kamejiroさん、ありがとうございます。そうか！入力元のセル番号をマクロを使って順次変えていけばいいということですね。わかりました。ありがとうございます。職場での要望の変化の対応するという事情もありましたが、”追加仕様”にとことんお付き合いくださいましたことに心より感謝申し上げます。

回答No.11

shiotan99

No.10です。何度もスミマセン。
No.10 はちょっとあわてていて、一通りの動作確認だけで送信してしまいました。
いまあらためてコードを見直すとそのあまりの稚拙さに絶句です。
とりあえず Exit Sub が多すぎ‥

ほとんど代わり映えはしませんが、↓の方で試してみてください。
動作的には No.10と何も変わりません。
◆ No.10に同じく、名前を上書きしたい場合は 「１中田」 とか 「３中田」 のように、《一桁の数字＋名前》でお願いします（ 修正可能なのは直前入力のみ ）。
'-------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim i As Integer, ret As Integer
　　Dim myName As String, myChgFlag As Boolean, myErrFlag As Boolean
　　Static myLastCell As String, myLastRow As Long

　　'---入力先（変更の場合↓を修正）
　　Const startCol As Integer = 17
　　Const endCol As Integer = 22

　　With Target
　　　　'---入力元（変更の場合↓を修正）
　　　　Select Case .Column
　　　　　　Case 35, 43, 51
　　　　　　Case Else
　　　　　　　　Exit Sub
　　　　End Select
　　　　If .Row < 5 Or .Count > 1 Then Exit Sub
　　　　If .Value = "" Then Exit Sub

　　　　If Not IsNumeric(Left(.Value, 1)) Then
　　　　　　myName = .Value
　　　　Else
　　　　　　'---名前上書きのエラーチェック
　　　　　　myChgFlag = False
　　　　　　myErrFlag = False
　　　　　　If Len(.Value) = 1 Then
　　　　　　　　myErrFlag = True
　　　　　　　　MsgBox "数字のあとに変更したい名前を入力してください！", vbExclamation
　　　　　　ElseIf myLastCell = "" Then
　　　　　　　　myErrFlag = True
　　　　　　　　MsgBox "前回入力情報がありません。直接変更してください。", vbInformation
　　　　　　ElseIf myLastRow <> .Row Then
　　　　　　　　myErrFlag = True
　　　　　　　　MsgBox "前回入力とは別の行に入力されています。" _
　　　　　　　　　　& vbNewLine & "名前を変更する場合、先ほどと同じ行に入力してください。", vbInformation
　　　　　　End If
　　　　　　If myErrFlag Then
　　　　　　　　Exit Sub
　　　　　　Else
　　　　　　　　myChgFlag = True
　　　　　　　　myName = LTrim(Mid(.Value, 2))
　　　　　　End If
　　　　End If
　　　　'---重複チェック
　　　　If WorksheetFunction.CountIf(Range(Cells(.Row, startCol), Cells(.Row, endCol)), myName) > 0 Then
　　　　　　MsgBox myName & "さんは入力済ですよ！", vbInformation
　　　　'---直前入力の変更
　　　　ElseIf myChgFlag Then
　　　　　　ret = MsgBox("入力済の「" & Range(myLastCell).Value _
　　　　　　　　& "」さんを「" & myName & "」さんに変更します。" _
　　　　　　　　& vbNewLine & vbNewLine & "よろしいですか？", vbQuestion + vbOKCancel)

　　　　　　If ret = vbOK Then
　　　　　　　　Application.EnableEvents = False
　　　　　　　　Range(myLastCell).Value = myName
　　　　　　　　.Value = myName
　　　　　　　　Application.EnableEvents = True
　　　　　　End If
　　　　'---入力件数オーバー
　　　　ElseIf WorksheetFunction.CountBlank(Range(Cells(.Row, startCol), Cells(.Row, endCol))) = 0 Then
　　　　　　MsgBox "この行にはこれ以上入力できません！", vbInformation

　　　　Else
　　　　　　For i = startCol To endCol
　　　　　　　　If Cells(.Row, i).Value = "" Then
　　　　　　　　　　Application.EnableEvents = False
　　　　　　　　　　Cells(.Row, i).Value = .Value
　　　　　　　　　　Application.EnableEvents = True
　　　　　　　　　　myLastCell = Cells(.Row, i).Address
　　　　　　　　　　myLastRow = .Row
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next i
　　　　End If
　　End With
End Sub
'-------------------------------------------------------

補足

shiotan99さん、本当に本当にありがとうございます。すばらしいものができました。

今度こそ最後にもう一つだけ教えてください。
いかにも超素人らしい質問ですが、
重複チェック時のメッセージボックスが不要である場合、「'---重複チェック　IfWorksheetFunction.CountIf(Range(Cells(.Row, startCol), Cells(.Row, endCol)), myName) > 0 Then MsgBox myName & "さんは入力済ですよ！", vbInformation」を削除したらよいかと思い、やってみたところ、不具合を起こすようです。せっかく素敵なメッセージを作っていただいたのですが、作業現場としてはそこまではいいよということでした。（登録先に入力できているとわかっていても入力元のほうでは入力するケースがあるとのことです）申し訳ありません。これにて最後の質問です。よろしくお願いいたします。

回答No.10

shiotan99

No.3 ＆ No.8です。

> 入力先の「田中」（誤）の上に「中田」（正）を
> 上書きということまでは難しいでしょうか？

単に 「中田」 と入力しただけでは、フツーに入力したいのか上書きしたいのか判断できませんよね。
これは上書きだよ～、とわかるものが名前の前にでも入力されていればできると思います。
何か記号を入力すればいいのですが、特定の記号だと何を入力するのか覚えていられるかちょっと不安です。

★ で、名前の前に何でもいいので数字を入力すれば、これは上書きしてね、というサインだということにしてみました。
上書きしたい場合は、「１中田」 とか 「３中田」 というように入力する、ということです。（ 一桁の数字です！ ）

↓な感じです（ 直前に入力したものしか変更できません ）。
'-----------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim i As Integer
　　Dim ret As Integer
　　Dim myName As String
　　Dim myFlag As Boolean
　　Static myLastCell As String
　　Static myLastRow As Long

　　'入力先（変更の場合↓を修正）
　　Const startCol As Integer = 17
　　Const endCol As Integer = 22

　　With Target
　　　　'入力元（変更の場合↓を修正）
　　　　Select Case .Column
　　　　　　Case 35, 43, 51
　　　　　　Case Else
　　　　　　　　Exit Sub
　　　　End Select
　　　　If .Row < 5 Or .Count > 1 Then Exit Sub
　　　　If .Value = "" Then Exit Sub

　　　　'名前の前が数字？
　　　　myFlag = False
　　　　If Not IsNumeric(Left(.Value, 1)) Then
　　　　　　myName = .Value
　　　　Else
　　　　　　If Len(.Value) = 1 Then
　　　　　　　　MsgBox "数字のあとに変更したい名前を入力してください！", vbExclamation
　　　　　　　　Exit Sub
　　　　　　End If
　　　　　　If myLastCell = "" Then
　　　　　　　　MsgBox "前回入力情報がありませんので変更できません！", vbInformation
　　　　　　　　Exit Sub
　　　　　　End If
　　　　　　If myLastRow <> .Row Then
　　　　　　　　MsgBox "現在位置が、前回入力した行番号とちがうので変更できません！", vbExclamation
　　　　　　　　Exit Sub
　　　　　　End If
　　　　　　myFlag = True
　　　　　　myName = LTrim(Mid(.Value, 2))
　　　　End If

　　　　If WorksheetFunction.CountIf(Range(Cells(.Row, startCol), Cells(.Row, endCol)), myName) > 0 Then
　　　　　　MsgBox myName & "さんは入力済ですよ！", vbInformation
　　　　　　Exit Sub
　　　　End If
　　　　'名前上書き
　　　　If myFlag Then
　　　　　　ret = MsgBox("入力済の「" & Range(myLastCell).Value _
　　　　　　　　& "」さんを「" & myName & "」さんに変更します。" _
　　　　　　　　& vbNewLine & vbNewLine & "よろしいですか？", vbQuestion + vbOKCancel)

　　　　　　If ret = vbOK Then
　　　　　　　　Application.EnableEvents = False
　　　　　　　　Range(myLastCell).Value = myName
　　　　　　　　.Value = myName
　　　　　　　　Application.EnableEvents = True
　　　　　　End If
　　　　　　Exit Sub
　　　　End If
　　　　If WorksheetFunction.CountIf(Range(Cells(.Row, startCol), Cells(.Row, endCol)), "") = 0 Then
　　　　　　MsgBox "この行にはこれ以上入力できません！", vbInformation
　　　　Else
　　　　　　For i = startCol To endCol
　　　　　　　　If Cells(.Row, i).Value = "" Then
　　　　　　　　　　Application.EnableEvents = False
　　　　　　　　　　Cells(.Row, i).Value = .Value
　　　　　　　　　　Application.EnableEvents = True
　　　　　　　　　　myLastCell = Cells(.Row, i).Address
　　　　　　　　　　myLastRow = .Row
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next i
　　　　End If
　　End With
End Sub
'------------------------------------------

お礼

shiotan99さん、ありがとうございます。ネットが職場でしかつながっていなくって、御礼が遅くなって申し訳ありません。今から確認してみます。取りいそぎ心からの感謝をと思います。まさかできるとは！VBAはすばらしいものですね。それ以上にshiotan99さんの構築力、すばらしいです。確認後No.12のお礼欄で改めて御礼申し上げます。他業務で遅くなるかもしれませんが・・・

回答No.9

Wendy02

こんばんは。Wendy02です。

もう、余計な口出しになると思いますので、コードの公開は控えますが、ちょっと、関わったので、一応書いておきます。

＞このようなケースで入力先の「田中」（誤）の上に「中田」（正）を上書きということまでは難しいでしょうか？

Static変数　にして、プロシージャの最後に、Targetのアドレスを確保すればよいのではありませんか？　後は、文字列の前に、プレフィックスでもつけて、例えば「!」などを付けて、通常入力とは分岐させて、修正用入力として、２文字目からを、前のセルに飛ばせば出来ますね。

----------------------------------
（Off Topic は削除される可能性があるのですが）
＞今回はポイントごめんなさい

人によりけりだと思いますが、ポイントよりも、質問者さんの心のこもったお礼の一言のほうが大きいものなのです。点数は心には残りませんが、丁寧なお礼は心に残ります。次の回答の励みになります。

お礼

Wendy02さん、いつもありがとうございます。職場でしかネットがなくて御礼がおそくなり申し訳ありません。Wendy02さんのコメントの方こそ、私の心に潤いをいただきました。ありがとうございます。ご指導内容については、私が初心者であることからも今は理解できていませんが、がんばって勉強してみますね。今後もよろしくお願いします。

回答No.8

shiotan99

No.3です。
いつの間にかずいぶんにぎやかになっていますね。

> たとえば、ｚ列まで拡張したいときは、
> 8行目の「For i = 17 To 22」をさわればいいのですね？

そうです。Z列の列番号は 26ですから
For i = 17 To 26
としてください。

> AI,AQ,AY・・・といくつか入力元を持ちたいのです。

AI列の列番号が 35ですから、
If .Column <> 35 Then Exit Sub

とすれば、AI列以外はここで処理を終了します。
AQ列、AY列も入力元にするなら、AND演算子でつなげてやってください。
列番号は、AQ列が 43、AY列が 51ですから、
If .Column <> 35 And .Column <> 43 And .Column <> 51 Then Exit Sub

となります。
または、
Select Case .Column
　　Case 35, 43, 51
　　Case Else
　　　　Exit Sub
End Select

としてもかまいません。入力元の列番号を
Case 35, 43, 51
のようにカンマをつけて列挙してください。
列番号がわからなければ、その列のどのセルでもいいので =COLUMN() と入力すればわかります。

整理すると、最初の部分は↓な感じです（ AI列、AQ列、AY列が入力元の場合 ）。
'-----------------------------------------
Dim i As Integer

With Target
　　'入力元
　　Select Case .Column
　　　　Case 35, 43, 51
　　　　Case Else
　　　　　　Exit Sub
　　End Select
　　If .Row < 5 Or .Count > 1 Then Exit Sub
　　If .Value = "" Then Exit Sub
'-----------------------------------------
◆
ついでに、No.3 をちょっと変更してみました（ 入力元…AI列、AQ列、AY列です ）。
↓の場合、入力先を拡張するときは、3行目の Const endCol As Integer = 22 の 22が V列の列番号ですから、これを修正してください。
'------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim i As Integer

　　'入力先（変更の場合↓を修正）
　　Const startCol As Integer = 17
　　Const endCol As Integer = 22

　　With Target
　　　 '入力元（変更の場合↓を修正）
　　　　Select Case .Column
　　　　　　Case 35, 43, 51
　　　　　　Case Else
　　　　　　　　Exit Sub
　　　　End Select
　　　　If .Row < 5 Or .Count > 1 Then Exit Sub
　　　　If .Value = "" Then Exit Sub

　　　　If WorksheetFunction.CountIf(Range(Cells(.Row, startCol), Cells(.Row, endCol)), "") = 0 Then Exit Sub
　　　　If WorksheetFunction.CountIf(Range(Cells(.Row, startCol), Cells(.Row, endCol)), .Value) > 0 Then Exit Sub

　　　　For i = startCol To endCol
　　　　　　If Cells(.Row, i).Value = "" Then
　　　　　　　　Application.EnableEvents = False
　　　　　　　　Cells(.Row, i).Value = .Value
　　　　　　　　Application.EnableEvents = True
　　　　　　　　Exit For
　　　　　　End If
　　　　Next i
　　End With
End Sub
'--------------------------------------------

補足

shiotan99さん、懇切丁寧なご回答、解説をありがとうございます。確認できました。ほぼ理想通りです。本当に感謝いたします。shiotan99さんのご回答を待ってよかったです^^

もう一点だけご質問をすることをお許しください。AI5に「田中」（誤）と入力（Entaer）して、あっ！間違えたということで「中田」（正）を入力しなおすと、入力先に「田中」残り、その次の列に「中田」が入ります。このようなケースで入力先の「田中」（誤）の上に「中田」（正）を上書きということまでは難しいでしょうか？

回答No.7

kamejiro

kamejiroです。
入力元列と入力先列に自由度を持たせたいのであれば、

入力元列　何行目から何行目か
入力先列　何列目から何列目か

こちらを別のシート（例えば、Sheet2）に値を入れてこちらを参照しながら動作するようにしてみてはいかがでしょうか。

Sheet2を次のように入力しておきます。
（例１）
　　　A　　　　　　B
1　入力元列番号　　27　　　…AA列
2　入力元開始行　　1
3　入力元終了行　　10　　　…1行目から10行目
4　入力先開始列　　1
5　入力先終了列　　26　　　…A列からZ列

（例２）
　　　A　　　　　　B
1　入力元列番号　　35　　　…AI列
2　入力元開始行　　1
3　入力元終了行　　13　　　…1行目から13行目
4　入力先開始列　　17
5　入力先終了列　　22　　　…Q列からV列

ＶＢＡは、

Sub テスト()
i = Worksheets("Sheet2").Cells(2, 2)
Do Until i = Worksheets("Sheet2").Cells(3, 2)
　　j = Worksheets("Sheet2").Cells(4, 2)
　　flg = ""
　　Do Until flg = "END"
　　　　If j = Worksheets("Sheet2").Cells(5, 2) Then
　　　　　　flg = "END"
　　　　End If
　　　　If Cells(i, j) = Cells(i, Worksheets("Sheet2").Cells(1, 2)) Then
　　　　　　flg = "END"
　　　　End If
　　　　If Cells(i, j) = "" Then
　　　　　　Cells(i, j) = Cells(i, Worksheets("Sheet2").Cells(1, 2))
　　　　　　flg = "END"
　　　　End If
　　　　j = j + 1
　　Loop
　　i = i + 1
Loop
End Sub

と書き換えてみてはいかがでしょうか。
※継ぎ接ぎの即席ＶＢＡゆえ、見づらいかもしれませんが…。

補足

kamejiroさん、深夜のご回答を感謝いたします。私の理解不足だけなのかもしれませんが、質問をお許しください。《入力先は一定で、『入力元』を複数同時にもちたい》ケースでの書き方が尚、わかりません。もしよろしければご指導お願いします。例えば、入力元がAI,AQ,AY・・・、入力先は変わらずQ～Vといった具合です。よろしくお願いいたします。

回答No.6

Wendy02

Wendy02です。なぜ、違っているのか、理由がわからなかったので、もう一度、ご質問自体を読み直してみました。

「AI列に新規の名前が入力されたときに自動入力すること」ということをキーワードにして考えてみました。

私は、「初めに、入力した文字ありき」という解釈でしたから。

もし、そういう条件だとしたら、以下のようなマクロでよいかと思います。

・特定の範囲に、文字があるなしに問わず、左詰で入力をしていく。
・特定の範囲に対して、重複を許さない
・特定の範囲を越えたら、入力させない。

まあ、これでダメなら、深追いしないほうがよいかもしれませんね。（^^;

以下は、ごちゃごちゃしているように見えるかもしれませんが、Visual Basic Editor に貼り付ければ見えます。

なお、これも、特定の範囲の中で、セルが空いている場合は、そこを左を優先に詰めます。なお、以下のコードは、かなりに特殊な部類のものになります。オーソドックスとは言えません。

'---------------------------------------------------

Private Sub Worksheet_Change(ByVal Target As Range)
　 Dim myCol As Integer
　 '==================================
　 '設定項目(入力開始+ 設定範囲)
　 Const IMPUT_ROW As Integer = 5 '行
　 Const IMPUT_COLUMN As Integer = 35 'AI列
　 '---------------------------------
　 Const LEFT_COLUMN As Integer = 17 '左列
　 Const RIGHT_COLUMN As Integer = 22 '右列
　 '==================================
　 With Target
　 If .Column <> IMPUT_COLUMN Or .Row < IMPUT_ROW Then Exit Sub
　 If .Count > 1 Then Exit Sub
　　　On Error Resume Next
　　　If WorksheetFunction.CountIf(Range(Cells(.Row, LEFT_COLUMN), Cells(.Row, RIGHT_COLUMN)), .Value) > 0 Then Exit Sub
　　　If WorksheetFunction.CountBlank(Range(Cells(.Row, LEFT_COLUMN), Cells(.Row, RIGHT_COLUMN))) = 0 Then MsgBox "その範囲は、一杯です。", vbInformation: Exit Sub
　　　myCol = Evaluate("MATCH(TRUE," & Range(Cells(.Row, LEFT_COLUMN), Cells(.Row, RIGHT_COLUMN)).Address & "="""",0)")
　　　If Err.Number > 0 Then Exit Sub
　　　On Error GoTo 0
　　　Application.EnableEvents = False
　　　Cells(.Row, LEFT_COLUMN + myCol - 1).Value = .Value
　　　Application.EnableEvents = True
　 End With
End Sub

'---------------------------------------------------
.

お礼

たびたび失礼します。質問を読み直してまで再度ご返答いただき、あらためて心より感謝いたします。私の質問がわかりにくかったのですね。ごめなさい。

さっきのお礼もこちらの欄に書くべきでした。またの機会にもこれに懲りずにご指導ください。ありがとうございました。^^

回答No.5

imogasi

P列にはいつもデータがあるとします。
Q-W列について左に詰めて追加します。質問に対し、Y列にデータを入れることに変えてます。
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 24 Then 'Y列について値変化
r = Target.Row
If Application.WorksheetFunction.CountIf(Range("Q" & r & ":W" & r), Target) = 0 Then
Range("w" & r).End(xlToLeft).Offset(0, 1) = Target
End If
End If
End Sub
短いことを趣旨にしてますが、普通には動きますが特殊ケースでは
ボロがでるかもしれません。

お礼

ご回答ありがとうございます。imogasiさんは、エクセルに関するご回答をいつもなさってますね^^実は私もそのご回答で勉強させていただいています。また、よろしくお願いします。（今回は、ポイントなくてごめんなさい<(_ _)>）

回答No.4

Wendy02

#3さんへ

Wendy02です。こちらのコードを、念のため、Watch 式 を取って見ましたが、値は正しくとれているようですが・・・。

＞No.1さんのだと、Q列からV列に何も入力されていないような場合うまくいかないと思います。

If (.End(xlToLeft).Column < 17 Or .End(xlToLeft).Column >= 22) Then Exit Sub

このように、除外条件を作っていますね。
つまり、35=AI列以下で、何も入っていない場合は、.End(xlToLeft).Column =1 になります。また、V列以降に入っている場合は、22 以上になりますから、除外されます。

＞重複チェックもちょっとちがうような‥

End プロパティで、ActiveCell や Target（セル）が移動するわけではありません。論理的ワークシートのセルの上を走るだけです。SelectやActivate で初めて移動します。

'　　AI列以下の最も右の列の値　と AI列の値
If .End(xlToLeft).Value <> .Value Then
'　見つかった場所から、セル１つ左に、Target（AI列の値）を代入する
　.End(xlToLeft).Offset(, 1).Value = .Value

ということです。

イベント・ドリブン型マクロの、ChangeやSelectionChangeイベントは、かなり重い部類に入りますから、なるべく簡易な方法で、そのプロシージャ内の停留時間を減らすのがよいと思います。WorksheetFunction を使った、他の手がないわけではないのですが、私としては、ご質問者のトラブルが、何が原因なのははっきりしませんが、この件はこのぐらいにしておきます。

お礼

Ｗendy02さん、いつもありがとうございます。質問に対する真摯な態度で取り組んでご回答くださることに感謝いたします。マクロ確認してみました。ありがとうございます。今回はポイントごめんなさい<(_ _)>
またご指導お願いいたします。

回答No.3

shiotan99

こんにちは～

Q列からV列がすべてうまっている状態で、AI列に別の名前を入力した場合はどうするのでしょうか？
それは考慮しなくてもよければ、以下のコードを試してみてください。

該当シートのシート見出しを右クリックして 「コードの表示」

'------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer

With Target
If .Column <> 35 Or .Row < 5 Then Exit Sub
If .Count > 1 Then Exit Sub
If .Value = "" Then Exit Sub

Application.EnableEvents = False
For i = 17 To 22
If Cells(.Row, i).Value = .Value Then
Exit For

Else
If Cells(.Row, i).Value = "" Then
Cells(.Row, i).Value = .Value
Exit For
End If
End If
Next i
Application.EnableEvents = True
End With

End Sub
'-----------------------------------------------------------

No.1さんのだと、Q列からV列に何も入力されていないような場合うまくいかないと思います。
あと、重複チェックもちょっとちがうような‥
かんちがいでしたらゴメンナサイ。

補足

shiotan99さん、ありがとうございました。完璧です。
Q～Vの6件を越えることはないと仕事で使う現場からの要望でしたが、増やしたいとき、たとえば、ｚ列まで拡張したいときは、8行目の「For i = 17 To 22」をさわればいいのですね？

もうひとつ、追加質問事項をお世話いただけるでしょうか？入力元をAIだけでなく、ほかにもいくつか設定したいのです。たとえばAI,AQ,AY・・・といくつか入力元を持ちたいのです。入力先はQ～Vで変更ありません。よろしくご指導お願いいたします。楽しみにお待ち申し上げています。