複数項目が同じ値である場合いくつかの条件の下で処理方法を変えたいのですが、どうしたらよいでしょうか。
参照は1行ずつ下に移行します。6行目の列1から列11までが表1となっており、6行目の列13から列30までが表2になっています。列の項目内容は似ていますが、表2のほうが項目数は多くなっています。要は表1の行と表2の行の指定内容が一致した場合に、条件によって処理をするということがしたいのです。
列1(A) 2 3 4... 11(K) 列13(M) 14 15 16... 30(AD)
日付 時刻 コード 委託者名 ... 日付 時刻 コード 委託者名...
マクロの内容としては
条件1. 列1と25M、列2と列26、列3と列15、列7と列S19が同じ値である場合
a 列8+列22=列9+列23 である場合・・・列1~列11・列13~列30を上方向に削除
b 列8+列22>列9+列33 であり、かつ列8>列9 である場合
r=列23の値
列8-r
列13~列30のみを上方向に消去
c 列8+列22>列9+列33であり、かつ列8<列9である場合
r=列23の値
列9-r
列13~列30のみを上方向に消去
d 列8+列22<列9+列33であり、かつ列22>列23である場合
r=列8の値
列22-r
列1~列11のみを上方向に消去
e 列8+列22<列9+列33であり、かつ列22<列23である場合
r=列8の値
列9-r
列1~列23のみを上方向に消去
条件2. 条件1以外は、次の行(n)へ移行する。
エラーにはならないのですが、マクロを作動させても、画面に反応がありません。基礎的な事がまだよく分かっていないので、単純なことかもしれませんが、どうしてもわかりません(涙)。
分かる方に教えていただこうと思い投稿させていただきました。よろしくお願いします。下記に、一応自分で作ったマクロを添付しています。
Sub Open_Positions2()
Dim n As Long
Dim i As Long
Dim r As Range
With Sheets("未決済")
For i = 6 To .Cells(Rows.Count, 1).End(xlUp).Row
For n = 6 To .Cells(Rows.Count, 13).End(xlUp).Row
If .Cells(i, 1).Value = .Cells(n, 25).Value And .Cells(i, 2).Value = .Cells(n, 26).Value And .Cells(i, 3).Value = .Cells(n, 14).Value And .Cells(i, 7).Value = .Cells(n, 19).Value Then
If .Cells(i, 8).Value + .Cells(n, 22).Value = .Cells(i, 9).Value + Cells(n, 23).Value Then
.Cells(i, 1).Resize(11).Delete Shift:=xlUp
.Cells(n, 13).Resize(18).Delete Shift:=xlUp
GoTo xyz
ElseIf .Cells(i, 8).Value + .Cells(n, 22).Value > .Cells(i, 9).Value + .Cells(n, 23).Value And .Cells(i, 8).Value > .Cells(i, 9) Then
Set r = .Cells(n, 23).Value
.Cells(i, 8).Value -r
.Cells(n, 13).Resize(18).Delete Shift:=xlUp
GoTo xyz
ElseIf .Cells(i, 8).Value + .Cells(n, 22).Value > .Cells(i, 9).Value + .Cells(n, 23).Value And .Cells(i, 8).Value < .Cells(i, 9) Then
Set r = .Cells(n, 23).Value
.Cells(i, 9).Value -r
.Cells(n, 13).Resize(18).Delete Shift:=xlUp
GoTo xyz
ElseIf .Cells(i, 8).Value + .Cells(n, 22).Value < .Cells(i, 9).Value + Cells(n, 23).Value And .Cells(n, 22).Value > .Cells(n, 23).Value Then
Set r = .Cells(i, 8).Value
.Cells(n, 22).Value -r
.Cells(i, 1).Resize(11).Delete Shift:=xlUp
ElseIf .Cells(i, 8).Value + .Cells(n, 22).Value < .Cells(i, 9).Value + Cells(n, 23).Value And .Cells(n, 22).Value < .Cells(n, 23).Value Then
Set r = .Cells(i, 8).Value
.Cells(n, 23).Value -r
.Cells(i, 1).Resize(11).Delete Shift:=xlUp
GoTo xyz
End If
Else
Debug.Print "Not Found"
End If
Next n
xyz:
Next i
End With
End Sub
お礼
ありがとうございます。