エクセル VBA 入力パターンごとの結果

質問

関数でもできると思うのですが、データが膨大ですごく重くなります。できたらマクロでと思ったのですが、自分ではうまくできませんでした。よろしくお願い致します。

D列５行目から、10000行目までに以下の条件で入力された場合の結果です。
【パターン(1)】
・”１”と入力された場合、（同じ行の）GからS列までに、”１”と自動入力。
・”２”と入力された場合、（同じ行の）GからT列までに、”１”と自動入力。
・”３”と入力された場合、（同じ行の）HからU列までに、”１”と自動入力。
・”４”と入力された場合、（同じ行の）IからV列までに、”１”と自動入力。
と各種パターンがあります。
【パターン(2)】
各行にパターン(1)が入力されたあと、以下の条件を加えたいのです。
E列５行目から、10000行目までに以下の条件が入ります。
・”１”と入力された場合、（同じ行の）I列は”0”に入力が変わる
・”２”と入力された場合、（同じ行の）J列は”0”に入力が変わる。
・”３”と入力された場合、（同じ行の）K列は”0”に入力が変わる
・”４”と入力された場合、（同じ行の）L列は”0”に入力が変わる

回答No.3

eden3616 · ベストアンサー

■コードの登録・仕様
シート右クリック→コードの表示でVBEを開き以下のVBAコードを貼り付けてください。
D列またはE列に「1」～「4」が入力されたら【パターン(1)】、【パターン(2)】の動作をします。
（一括での範囲コピー、貼付にも対応しています）

■VBAコード

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim j As Long
Dim ptn1() As Variant
Dim ptn2() As Variant
ptn1 = Array("G1:V1", "G1:S1", "G1:T1", "H1:U1", "I1:V1")
ptn2 = Array("I1", "J1", "K1", "L1")
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error GoTo era
For j = Target(1).Column To Target(Target.Count).Column
　　If j = Cells(1, "D").Column Or j = Cells(1, "E").Column Then
　　　　For i = Target(1).Row To Target(Target.Count).Row
　　　　　　If 5 <= i And i <= 10000 Then
　　　　　　　　Select Case j
　　　　　　　　Case Cells(1, "D").Column
　　　　　　　　　　Range(ptn1(0)).Offset(i - 1).ClearContents
　　　　　　　　　　If Cells(i, j).Value <> "" Then
　　　　　　　　　　　　Range(ptn1(Cells(i, j).Value)).Offset(i - 1) = 1
　　　　　　　　　　End If
　　　　　　　　Case Cells(1, "E").Column
　　　　　　　　　　If Cells(i, j).Value <> "" Then
　　　　　　　　　　　　Range(ptn2(Cells(i, j).Value - 1)).Offset(i - 1) = 0
　　　　　　　　　　End If
　　　　　　　　End Select
　　　　　　End If
　　　　　　DoEvents
　　　　Next i
　　End If
Next j
era:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

お礼

大変、遅れて申し訳ありません。ありがとうございました。

回答No.4

tom04

No.1です。

＞E列５行目から、10000行目までに以下の条件が入ります
を見逃していました。
すべてD列の処理だと勘違いしていましたので、
前回のコードはきれいに消去して↓のコードに変更してください。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
If Intersect(Target, Range("D5:E10000")) Is Nothing Or Target.Count > 1 Then Exit Sub
With Target
If .Column = 4 Then
Range(Cells(.Row, "G"), Cells(.Row, "V")).ClearContents
Select Case .Value
Case 1
Range(Cells(.Row, "G"), Cells(.Row, "S")) = 1
Case 2
Range(Cells(.Row, "G"), Cells(.Row, "T")) = 1
Case 3
Range(Cells(.Row, "H"), Cells(.Row, "U")) = 1
Case 4
Range(Cells(.Row, "I"), Cells(.Row, "V")) = 1
End Select
Else
If WorksheetFunction.Count(Range(Cells(.Row, "G"), Cells(.Row, "V"))) Then
Set c = Range(Cells(.Row, "G"), Cells(.Row, "V")).Find(what:=0, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
c = 1
End If
Select Case .Value
Case 1
Cells(.Row, "I") = 0
Case 2
Cells(.Row, "J") = 0
Case 3
Cells(.Row, "K") = 0
Case 4
Cells(.Row, "L") = 0
End Select
End If
End If
End With
End Sub

※　今回はE列数値が変わっても対応できるようにしてみました。m(_ _)m

お礼

大変、遅れて申し訳ありません。ありがとうございました。

回答No.2

keithin

Ｇ列　Ｄが１または２の時１，それ以外""
　=IF(OR(D5=1,D5=2),1,"")
Ｈ列　Ｄが１，２，３の時１，それ以外""
　=IF(OR(D5=1,D5=2,D5=3),1,"")
Ｉ列　Ｄが１の時０，Ｄが２，３，４の時１，それ以外""
　=IF(D5=1,0,IF(AND(1<=D5,D5<=4),1,""))
Ｊ列　Ｄが２の時０，Ｄが１，３，４の時１，それ以外""
　=IF(D5=2,0,IF(AND(1<=D5,D5<=4),1,""))
Ｋ列　Ｄが３の時０，Ｄが１，２，４の時１，それ以外""
　=IF(D5=3,0,IF(AND(1<=D5,D5<=4),1,""))
Ｌ列　Ｄが４の時０，Ｄが１，２，３の時１，それ以外""
　=IF(D5=4,0,IF(AND(1<=D5,D5<=4),1,""))
Ｍ列　Ｄが１から４の時１，それ以外""
　=IF(AND(1<=D5,D5<=4),1,"")
Ｎ～Ｓ列　Ｍ列と同じ
　=M5
Ｔ列　Ｄが２から４の時１，それ以外""
　=IF(AND(2<=D5,D5<=4),1,"")
Ｕ列　Ｄが３又は４の時１，それ以外""
　=IF(OR(D5=3,D5=4),1,"")
Ｖ列　Ｄが４の時１，それ以外""
　=IF(D5=4,1,"")
それぞれ以下コピー

この程度の計算であれば，仮に毎回１万行ずつ一斉に記入しても，負担を感じることはありません。
仮に回答通りに作成しそれでも「重くて困ってる」のでしたら，シートのどこかにある，今回のご相談では触れられていない別の数式が原因です。

お礼

大変、遅れて申し訳ありません。ありがとうございました。

回答No.1

tom04

こんにちは！

画面左下の操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペースト　→　Excel画面に戻り、D列に数値を入力してみてください。

Private Sub Worksheet_Change(ByVal Target As Range) 'この行から
Dim myRng As Range
If Intersect(Target, Range("D5:D10000")) Is Nothing Or Target.Count > 1 Then Exit Sub
With Target
Select Case .Value
Case 1
Set myRng = Range(Cells(.Row, "G"), Cells(.Row, "S"))
If WorksheetFunction.Count(myRng) Then
Cells(.Row, "I") = 0
Else
myRng = 1
End If
Case 2
Set myRng = Range(Cells(.Row, "G"), Cells(.Row, "T"))
If WorksheetFunction.Count(myRng) Then
Cells(.Row, "J") = 0
Else
myRng = 1
End If
Case 3
Set myRng = Range(Cells(.Row, "H"), Cells(.Row, "U"))
If WorksheetFunction.Count(myRng) Then
Cells(.Row, "K") = 0
Else
myRng = 1
End If
Case 4
Set myRng = Range(Cells(.Row, "I"), Cells(.Row, "V"))
If WorksheetFunction.Count(myRng) Then
Cells(.Row, "L") = 0
Else
myRng = 1
End If
Case ""
Range(Cells(.Row, "G"), Cells(.Row, "V")).ClearContents
End Select
End With
End Sub 'この行まで

※　一旦各行に「1」が表示されている状態でD列数値を色々返ると「0」が異なる列に表示されますので、
Deleteで削除するととりあえず「1」はすべて消えるようにしています。

※　一発で解決！とはいかないと思いますが、
たたき台としての一例です。m(_ _)m

お礼

大変、遅れて申し訳ありません。ありがとうございました。