Excel VBA質問箱 IV

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

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


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

54524 / 76732

←次へ　｜　前へ→


	【26998】Re:合計値の求め方

Jaka - 05/7/26(火) 10:20 -


	引用なし

	パスワード

何となく他の方法でも作ってみました。
データがこんな感じで、１行目は項目名などとして。
ソートも加えてみました。。

　　　Ａ　　　　　Ｂ
１　　日付　　　　数
２　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

0 hits

▼

【26949】合計値の求め方 nana 05/7/25(月) 13:06