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

Question

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

Wendy02 · Answer

こんにちは。こんなものでよいと思います。イベント・ドリブン型のマクロですから、使い方は、単に、AI列に入力するだけです。 'シートタブから、コードの表示で以下を貼り付けます。 '--------------------------------------------------- Private Sub Worksheet_Change(ByVal Target As Range) 　 With Target 　 '35列 =AI列　 If .Column <> 35 Then Exit Sub 　 If .Count > 1 Then Exit Sub '複数のセルの場合のEnter除外　 '17 =Q列より前か 22= V列より後は除外　 If (.End(xlToLeft).Column < 17 Or .End(xlToLeft).Column >= 22) Then Exit Sub 　　　If .End(xlToLeft).Value <> .Value Then 　　　　 Application.EnableEvents = False 　　　　 .End(xlToLeft).Offset(, 1).Value = .Value 　　　　 Application.EnableEvents = True 　　　End If 　 End With End Sub '--------------------------------------------------- .

onntao · Answer

kamejiroさんの応用ということなら
それぞれの入力位置を検討といううことになるかと
Sub テスト2()

i = 1
Do Until Cells(i, 35) = ""
    j = 17
    flg = ""
    Do Until flg = "END"
        If j = 22 Then
            flg = "END"
        End If
        If Cells(i, j) = Cells(i, 35) Then
            flg = "END"
        End If
        If Cells(i, j) = "" Then
            Cells(i, j) = Cells(i, 35)
            flg = "END"
        End If
        j = j + 1
        Loop
    i = i + 1
Loop
End Sub

それにしてもkamejiroさん、最初からこのような変更もありうるとを想定してのコードなのかすばらしいな～ ('-'*)
　VBA勉強中の　onntaoでした

shiotan99 · Answer

こんにちは～

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列に何も入力されていないような場合うまくいかないと思います。
あと、重複チェックもちょっとちがうような‥
かんちがいでしたらゴメンナサイ。

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

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

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

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

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

Wendy02 · Answer

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

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

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

こんにちは。

この回答への補足

kamejiroさんの応用ということなら

この回答への補足

こんにちは～

この回答への補足

#3さんへ

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

Wendy02です。

kamejiroです。

この回答への補足

No.3です。

この回答への補足

こんばんは。

No.3 ＆ No.8です。

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

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

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

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