|
Help me!! さん、こんにちわ。
一部修正。
Sub test()
Dim wb As Workbook, ws1 As Worksheet
Dim r1 As Range, r2 As Range, r3 As Range, Rpos1&, Rpos2&, Rpos&
Set wb = ActiveWorkbook
Set ws1 = Application.Workbooks.Add.Worksheets(1) '新しいブック
'
With wb.Worksheets("A")
Rpos1& = .Range("A65536").End(xlUp).Row
Set r1 = .Range(.Cells(2, 1), .Cells(Rpos1&, 2))
End With
With wb.Worksheets("B")
Rpos2& = .Range("A65536").End(xlUp).Row
Set r2 = .Range(.Cells(2, 1), .Cells(Rpos2&, 2))
End With
'
With ws1
'
.Range("A1").Value = "管理番号"
.Range("B1").Value = "金額A"
.Range("C1").Value = "金額B"
'値だけ貼る
r1.Copy: .Cells(2, 1).PasteSpecial xlValue
.Cells(2, 4).Value = 100001
.Range(.Cells(2, 4), .Cells(Rpos1&, 4)).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
'
'下に追加
r2.Copy: .Cells(Rpos1& + 1, 1).PasteSpecial xlValue
Rpos2& = .Range("A65536").End(xlUp).Row '位置再計算
.Cells(Rpos1& + 1, 4).Value = 200001
.Range(.Cells(Rpos1& + 1, 4), .Cells(Rpos2&, 4)).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
'戻す為のソートキーをDに付与
'並べ替え
.Range(.Cells(2, 1), .Cells(Rpos2&, 4)).Sort key1:=.Cells(2, 1), Order1:=xlAscending, _
key2:=.Cells(2, 4), Order2:=xlAscending, _
Header:=xlNo, SortMethod:=xlStroke
'
Set r3 = .Cells(Rpos2& + 1, 4) '無条件で削除してもよい行
Rpos& = Rpos2&
'
Do
If .Cells(Rpos&, 1).Value = .Cells(Rpos& - 1, 1).Value Then
If .Cells(Rpos&, 2).Value = .Cells(Rpos& - 1, 2).Value Then
'削除対象
Set r3 = Application.Union(r3, .Cells(Rpos&, 4), .Cells(Rpos& - 1, 4))
Else
'データを繰り上げて1つ削除
.Cells(Rpos, 2).Cut .Cells(Rpos - 1, 3)
Set r3 = Application.Union(r3, .Cells(Rpos&, 4))
End If
Rpos& = Rpos& - 1
Else
If .Cells(Rpos, 4).Value > 200000 Then _
.Cells(Rpos, 2).Cut .Cells(Rpos, 3)
End If
Rpos& = Rpos& - 1
Loop While Rpos& > 2
r3.EntireRow.Delete
'ソートして元のならびに戻す
Rpos2& = .Range("A65536").End(xlUp).Row
.Range(.Cells(2, 1), .Cells(Rpos2&, 4)).Sort key1:=.Cells(2, 4), Order1:=xlAscending
'ソートキー削除
.Columns(4).Delete
.Range("A1").Select
End With
'
Set r1 = Nothing: Set r2 = Nothing: Set r3 = Nothing
Set ws1 = Nothing: Set wb = Nothing
End Sub
今は時間がとれないので、わからないところがあれば解説はまた後ほど。
|
|