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

Question

応用が効かなくて申し訳ありません。
1798323で素敵なご回答をいただいたのですが、
状況が進展して変わってくるとＶＢＡの書き換えがわからなくなりました。もう一度教えてください。

※変更点は、入力元がAI列、『入力先をＱ～Ｖ列に限定』したい点です。

　　Q 　　　R　　　 S 　　 T 　　U　V・・ AI
1 田中　鈴木　佐藤　　　　　　　　　　山田
2 鈴木　山田 　　　　　　　　　　　　　海岡
3 田中　佐藤 　　　　　　　　　　　　　佐藤

というような表があり、T1に「山田」、S2「海岡」と、その行に関してAI列に新規の名前が入力されたときに自動入力することをVBAでどのように書けばよいのか、ご教授お願いいたします。
尚、3行目には「佐藤」さんがすでいるので入力不要です。
よろしくお願いします。

shiotan99 · Accepted Answer

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
'----------------------
に変更してください。

kamejiro · Answer

＃７です。日数が経ちましたが…。
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さん。丁寧な回答には大変参考になります…。入力誤りを訂正するといった応用って…、整合性の取れたロジックを考えつくなんて…。

shiotan99 · Answer

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 · Answer

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
'------------------------------------------

Wendy02 · Answer

こんばんは。Wendy02です。

もう、余計な口出しになると思いますので、コードの公開は控えますが、ちょっと、関わったので、一応書いておきます。

＞このようなケースで入力先の「田中」（誤）の上に「中田」（正）を上書きということまでは難しいでしょうか？

Static変数　にして、プロシージャの最後に、Targetのアドレスを確保すればよいのではありませんか？　後は、文字列の前に、プレフィックスでもつけて、例えば「!」などを付けて、通常入力とは分岐させて、修正用入力として、２文字目からを、前のセルに飛ばせば出来ますね。

----------------------------------
（Off Topic は削除される可能性があるのですが）
＞今回はポイントごめんなさい

人によりけりだと思いますが、ポイントよりも、質問者さんの心のこもったお礼の一言のほうが大きいものなのです。点数は心には残りませんが、丁寧なお礼は心に残ります。次の回答の励みになります。

shiotan99 · Answer

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 '--------------------------------------------

kamejiro · Answer

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

Wendy02 · Answer

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 '--------------------------------------------------- .

imogasi · Answer

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
短いことを趣旨にしてますが、普通には動きますが特殊ケースでは
ボロがでるかもしれません。

Wendy02 · Answer

#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 を使った、他の手がないわけではないのですが、私としては、ご質問者のトラブルが、何が原因なのははっきりしませんが、この件はこのぐらいにしておきます。

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

No.11です。

＃７です。

No.10です。

この回答への補足

No.3 ＆ No.8です。

こんばんは。

No.3です。

この回答への補足

kamejiroです。

この回答への補足

Wendy02です。

P列にはいつもデータがあるとします。

#3さんへ

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング