Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

52618 / 76736

←次へ　｜　前へ→


	【28953】Re:日々のデータを1件だけ残して、それ以外...

Statis - 05/9/19(月) 15:45 -


	引用なし

	パスワード

こんにちは
>まず、そういうことはありません。
と考えて
お試しを（Errの処理はしていません）
該当シートを「Sheet1」としています。

Sub Test()
Dim R As Range, C As Range, Ro As Long
Ro = 2
Application.ScreenUpdating = False
With Worksheets("Sheet1")
　　.Range("A1").Sort Key1:=.Range("A2"), Order1:=xlAscending, Key3:=.Range("N2") _
　　　　, Order3:=xlAscending, Header:=xlGuess
　　 .Range("A1").Subtotal GroupBy:=1, Function:=xlMax, TotalList:=Array(14), _
　　　　Replace:=True, PageBreaks:=False, SummaryBelowData:=True
　　 Set R = .Range("M2:M" & .Range("N65536").End(xlUp).Row - 1).SpecialCells(xlCellTypeBlanks)
　　 For Each C In R
　　　　 .Cells(Ro, 15).Resize(C.Row - Ro).Formula = _
　　　　　"=IF(" & C.Offset(, 1).Address & "=" & "N" & Ro & ","""",1)"
　　　　　.Cells(Ro, 15).Resize(C.Row - Ro).Value = .Cells(Ro, 15).Resize(C.Row - Ro).Value
　　　　 Ro = C.Row + 1
　　 Next C
　　 .Columns(15).SpecialCells(xlCellTypeConstants).EntireRow.Delete
　　 .Range("A1").RemoveSubtotal
　　 Set R = Nothing
End With
Application.ScreenUpdating = True
End Sub

0 hits

▼

【28949】日々のデータを1件だけ残して、それ以外... haru 05/9/19(月) 14:10