| |
それぞれのシートの
１行目が見出し、２行目からデータ
Ａ列がコード、Ｂ列が金額として。
Sub test()
Dim wb As Workbook, ws1 As Worksheet
Dim r1 As Range, r2 As Range, Rpos1&, Rpos2&, Rpos&
Set wb = ActiveWorkbook
wb.Worksheets("A").Copy '新しいシートが新しいブックにできる
Set ws1 = Application.ActiveSheet
'
With wb.Worksheets("B")
Set r1 = .Range(.Range("A2"), .Range("A2").End(xlDown)).EntireRow
End With
'
With ws1
Rpos1& = .Range("A65536").End(xlUp).Row
.Cells(2, 4).Value = 100001
.Range(.Cells(2, 4), .Cells(Rpos1&, 4)).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
'
'下に追加
r1.Copy Destination:=.Cells(Rpos1& + 1, 1)
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 r2 = .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 r2 = Application.Union(r2, .Cells(Rpos&, 4), .Cells(Rpos& - 1, 4))
Else
'データを繰り上げて1つ削除
.Cells(Rpos, 2).Cut .Cells(Rpos - 1, 3)
Set r2 = Application.Union(r2, .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
r2.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("B1").Value = "金額A"
.Range("C1").Value = "金額B"
End With
'
Set r1 = Nothing: Set r2 = Nothing
Set ws1 = Nothing: Set wb = Nothing
End Sub
|
|
りん
- 05/9/2(金) 13:03 -
