| |
SoundPower さん、こんにちわ。
>A列の数字がデータのセットを表し、1セットの合計が約100なのです。
>よって1個しかない（自動的に１００）場合はいいのですが、複数ある
>場合、例えば、
>A E
>3 20
> 40
> 15
> +) 25
> 100
>3というセットの中でE列で最大なのは上から2番目の40というわけです。
>この時、A列は空欄ですがA列からE列までの範囲のデータを抽出したいのです。
データが連続しているところがEndキー+↑、Endキー+↓で判定できるものとして。
A列に数字のはいっていないところがセットの1つと考えて、
・新しいシートにコピー
・各セット毎の最大値抽出（最大値でないものを抽出して削除）
・A列の数字が０〜３を繰り返しているかどうかを判定して抜けてたら挿入
Sub TEST()
Dim ws1 As Worksheet, ws2 As Worksheet, r1 As Range, r2 As Range
Dim Rmax As Long, RR As Long, NN As Integer
Dim Rp1 As Long, Rp2 As Long, Rp3 As Long, Rp4 As Long, Mdat As Double
'
Set ws1 = Application.ActiveSheet '転記先
Set ws2 = Application.Workbooks.Add.Worksheets(1) '転記元
'コピー元範囲
With ws1
Rmax = .Range("E65536").End(xlUp).Row
Set r1 = .Range(.Cells(1, 1), .Cells(Rmax, 5))
End With
r1.Copy
'コピー先（念のため値のみ転記）
ws2.Cells(1, 1).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
'A列が空白のところは、チェック対象
With ws2
Set r2 = .Cells(Rmax + 1, 1) '削除しても影響のないセル
'
Do
RR = .Cells(Rmax, 1).End(xlUp).Row
If RR = 1 Then Exit Do '一番上まで連続になったらループを抜ける
'合計する範囲
Rp2 = RR - 1 '一番下の行
Rp1 = .Cells(RR, 1).End(xlUp).Row '一番上の行
'一番上の値が暫定の最大値
Rp4 = Rp1
Mdat = .Cells(Rp4, 5).Value
'最大値のチェック、最大値でないセルは削除用変数r2にセット
For Rp3 = Rp1 + 1 To Rp2
.Cells(Rp3, 1).Value = .Cells(Rp1, 1).Value
If .Cells(Rp3, 5).Value > Mdat Then
Mdat = .Cells(Rp3, 5).Value
Set r2 = Application.Union(r2, .Cells(Rp4, 1)) '元の最大値セル
Rp4 = Rp3 '行番号
Else
Set r2 = Application.Union(r2, .Cells(Rp3, 1)) '小さかった
End If
Next
Loop
End With
r2.EntireRow.Delete 'まとめて行全体削除
Set r2 = Nothing
'最下行を再チェック
With ws2
Rmax = .Range("E65536").End(xlUp).Row
Rp1 = 2
Do
For RR = Rp1 To Rmax
NN = .Cells(RR, 1).Value - .Cells(RR - 1, 1).Value
Select Case NN
Case -3, 1
Case Else
'行挿入
.Cells(RR, 1).EntireRow.Insert
.Cells(RR, 1).Value = (.Cells(RR - 1, 1).Value + 1) Mod 4
.Cells(RR, 5).Value = 0
Rp1 = RR + 1 '次のチェックは挿入行のひとつ下から
Rmax = Rmax + 1 '１行挿入したので最大値を＋１
Exit For
End Select
NN = -9 'ループを中断したか、最後までまわしたかの判定用
Next
Loop Until NN = -9 '最後まで無事にまわると抜ける
End With
'
Set ws2 = Nothing: Set ws1 = Nothing
End Sub
とりあえず、こんな感じです。
|
|
りん
- 07/1/9(火) 14:05 -
