| |
何となく他の方法でも作ってみました。
データがこんな感じで、１行目は項目名などとして。
ソートも加えてみました。。
Ａ Ｂ
１ 日付 数
２ 2005/7/3 1
３ 2005/7/2 1
４ 2005/7/5 1
５ 2005/7/4 1
６ 2005/7/1 1
７ 2005/7/2 1
８ 2005/7/5 1
Sub オートフィルタ() '思ったほど速くない。遅い？
Dim AdRg As Range, CEL As Range, FlSt() As String, CT As Long, SSt As Variant
Dim SumAd As String
Application.ScreenUpdating = False
Range("A1").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess
With Range("A1", Range("A65536").End(xlUp))
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set AdRg = .Resize(.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible)
ActiveSheet.ShowAllData
For Each CEL In AdRg
CT = CT + 1
ReDim Preserve FlSt(1 To CT)
FlSt(CT) = CEL
Next
For Each SSt In FlSt
DtSt = Format(SSt, "yyyy/mm/dd")
.AutoFilter Field:=1, Criteria1:=">=" & DtSt, Operator:=xlAnd, _
Criteria2:="<=" & DtSt
Set FlRg = .Resize(.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible)
ActiveSheet.AutoFilterMode = False
FlRg.Cells(FlRg.Count).Offset(1).EntireRow.Insert
SumAd = FlRg.Offset(, 1).Address(0, 0)
FlRg.Cells(FlRg.Count).Offset(1, 1).Select
FlRg.Cells(FlRg.Count).Offset(1, 1).Formula = "=sum(" & SumAd & ")"
Next
End With
Application.ScreenUpdating = True
Erase FlSt
Set AdRg = Nothing
Set FlRg = Nothing
MsgBox "終わりました。"
End Sub
Sub 一つづつ比較()
Dim CEL As Range
Application.ScreenUpdating = False
Range("A1").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess
For Each CEL In Range("A2", Range("A65535").End(xlUp))
If CEL.Value <> CEL.Offset(1).Value And _
CEL.Value <> "" Then
CEL.Offset(1).EntireRow.Insert
subad = Range(CEL, CEL.End(xlUp)).Offset(, 1).Address(0, 0)
CEL.Offset(1, 1).Formula = "=sum(" & subad & ")"
End If
Next
Application.ScreenUpdating = True
MsgBox "終わりました。"
End Sub
Sub SumIF版()
Application.ScreenUpdating = False
Range("A1").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess
For Each CEL In Range("A2", Range("A65535").End(xlUp))
If CEL.Value <> CEL.Offset(1).Value And _
CEL.Value <> "" Then
CEL.Offset(1).EntireRow.Insert
CEL.Offset(1, 1).Formula = "=SUMIF($A$1:A" & CEL.Row & ",A" & CEL.Row & ",$B$1:$B" & CEL.Row & ")"
End If
Next
Application.ScreenUpdating = True
MsgBox "終わりました。"
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
