エクセルＶＢＡで平均値を求める方法

質問

みなさん教えてください。

今、実験で測定したデータの整理を行っています。
そこで、教えて頂きたいことがあります。

下記のようなデータの整理を行っています。
今行いたいことは、下図のようなプラスとマイナスの数値（図ではＡ・Ｂ・Ｃエリアと区別）に
おける各エリアの個別の平均値をマクロで求めたいと思っています。

＜データの詳細＞
・データ数は全部で約４００個
・データは、下図のようにプラスの数値のあとにマイナスの数値がくるようになっています。

みなさんマクロで求める方法（構文）を教えて頂けないでしょうか。

よろしくお願いします。

回答No.7

Wendy02

質問者は、戻らないのかもしれませんが、#4のマクロをもう少しそぎ落としてみました。数式と違う部分は、空白があっても、誤動作しません。文字に関しては、同じ仕様です。

'*書きだし場所は変更出来ます。
'//
Sub EachAverage2()
　Dim rng As Range
　Dim i As Long
　Dim iStr As Long, iEnd As Long
　Dim dSum As Double, cnt As Long
　Set rng = Range("A1", Cells(Rows.Count, 1).End(xlUp)) 'A1とCells(Rows.Count, 1)の1 の列は合わせること。
　rng.Offset(, 1).ClearContents
　iStr = rng.Cells(1).Row
　iEnd = rng.Cells(rng.Cells.Count).Row　'隣の列は一旦クリアされます。
　Application.ScreenUpdating = False
　'*
　For i = iStr To iEnd
　　If Val(Cells(i, 1).Value) > -1 Eqv Val(Cells(i + 1, 1).Value) > -1 Then
　　　dSum = dSum + Val(Cells(i, 1).Value)
　　　cnt = cnt - (VarType(Cells(i, 1)) = vbDouble)
　　Else
　　　dSum = dSum + Val(Cells(i, 1).Value)
　　　cnt = cnt - (VarType(Cells(i, 1)) = vbDouble)
　　　Cells(i, 2).Value = dSum / cnt '*
　　　cnt = 0
　　　dSum = 0
　　End If
　Next i
　Cells(i - 1, 2).Value = dSum / cnt '*
　Application.ScreenUpdating = True
　Set rng = Nothing
End Sub

回答No.6

MackyNo1

数式で計算するなら以下のような一覧表を作成するのが簡単かもしれません（添付図参照）。

C2セルに「１」と入力

符号の切り替わりの行番号のC3セル（下方向にオートフィル）

=MIN(INDEX((INDEX($A$1:$A$400,C2):$A$400*(-1)^ROW(A2)>0)*1000+ROW(INDEX($A$1:$A$400,C2):$A$400),))

平均値のD2セル（下方向にオートフィル）

=IF(COUNT(A:A)<C2,"",AVERAGE(OFFSET($A$1,C2-1,0,C3-C2,1)))

数式が複雑になるので処理しませんでしたが、符号の切り替わりの行番号の最後の表示したいくない部分は、IF関数や条件付き書式で表示しないような設定にもできます。

回答No.5

Wendy02

#4の回答で、数式に触れましたので、数式は、あまり得意ではないのですが、数式も書いておきます。

B1 から、=IF(ROW(A1)=1,0,IF(OR((A1>-1)<>(A2>-1),ISBLANK(A2)),ROW(),""))
　をフィルダウン・コピー（トップのフィルハンドルをダブルクリック）
C2 から、=IF(B2<>"",AVERAGE(INDEX(A:A,MAX($B$1:B1)+1,1):INDEX(A:A,B2,1)),"")
　をフィルダウン・コピー（トップのフィルハンドルをダブルクリック）

つまり、マクロで数式を貼り付けてもよいかもしれませんね。

回答No.4

Wendy02

データに数値のないものが含まれるエラー処理を含めています。
計算の排出先は、* がついている部分ですから、列の隣なら、.Cells(i, 2).Value ですから、この2 を換えてあげればよいです。また、Celltop のセルの先頭を最初に設定すれば、場所を変えることが出来ます。 Average 関数は使いませんが、Average関数の文字に対するの考え方を反映するようにしました。

ただ、これは、あくまでも、VBAマクロという前提で、並んでいる環境なら関数でも可能なような気がします。

'//
Sub EachAvarages()
　Dim CellTop As Range, rng As Range
　Dim i As Long, cnt As Long
　Dim dSum As Double
　Dim F As Long, iFlg As Integer

　Set CellTop = Range("G5") 'セルの先頭
　Set rng = Range(CellTop, Cells(Rows.Count, CellTop.Column).End(xlUp))
　If Application.CountA(rng) = 0 Then MsgBox "データがありません。", 48: Exit Sub
　'rng.Offset(, 1).ClearContents '右隣の列のデータ削除(必要に応じて外してください）
　Application.ScreenUpdating = False
　With rng
　　For i = 1 To rng.Rows.Count
　　If F = 0 Then F = i: iFlg = Val(Cells(i, 1)) > -1
　　　If i = rng.Rows.Count Then
　　　If VarType(.Cells(i, 1)) = vbDouble Then cnt = cnt + 1
　　　　.Cells(i, 2).Value = (dSum + Val(.Cells(i, 1).Value)) / cnt '*
　　　　Exit For
　　　End If
　　　If VarType(.Cells(i + 1, 1)) = vbDouble Then
　　　　iFlg = Val(.Cells(i, 1).Value) > -1
　　　　If VarType(.Cells(i, 1).Value) <> vbDouble Then iFlg = 0
　　　　If CInt(Val(.Cells(i + 1, 1).Value) > -1) <> iFlg Then
　　　　　dSum = dSum + Val(.Cells(i, 1).Value)
　　　　　cnt = cnt + 1
　　　　　.Cells(i, 2).Value = dSum / cnt '*
　　　　　dSum = 0: F = i: cnt = 0
　　　　Else
　　　　　dSum = dSum + Val(.Cells(i, 1).Value)
　　　　　cnt = cnt + 1
　　　　End If
　　　Else
　　　　 dSum = dSum + Val(.Cells(i, 1).Value)
　　　End If
　　Next i
　End With
　Application.ScreenUpdating = True
　Set rng = Nothing: Set CellTop = Nothing
End Sub

回答No.3

imogasi

いまこの質問を見ると画像が真っ黒で、どういうデータか判らないよ。
一般に
（１）例データは質問文にテキストで作成するようにしてほしい。
（２）質問者は質問をOKWAVEに上げた後、読者の立場で一度照会してみてほしい。
ーー
平均値を求める方法は
（１）エクセル関数で求める
AVERAGEIFやSUMIF
質問者にはこれで良いのでは。
（２）エクセル関数をVBAで使う方法
（３）各行のデータをとらえて計算していくとき
データ数と
そこの行までの合計を足していく、最後に合計を件数で割る
方法（有名な初歩的アルゴリズム）と在る。
ーー
本件も画像が見えないので答えられないが、クラス（A,B,Cか）分けと符号が尋常ではないようだから、
それを新しい列に普通のデータに作れば、後はエクセル関数利用などで簡単でしょう。
計算だけなら、VBAでやる意味は余り無いと思う。
VBAを使う理由を認識できているか疑問。

回答No.2

某HN クロメート(Chromate)（@CoalTar）

お遊びで参加
数式のみなんだけど(^^;)
Sub Macro1()
Application.ScreenUpdating = False

　 　Dim 終わり行 As Long
　 　終わり行 = Cells(Rows.Count, 1).End(xlUp).Row

　 　Range("B:D").Insert

　 　Range("B1") = Range("A1").Value
　 　Range("B2:B" & 終わり行).Formula = _
　 　 　 　"=IF(SIGN(A1)=SIGN(A2),SUM(A2,B1),A2)"

　 　Range("C1") = 1
　 　Range("C2:C" & 終わり行).Formula = _
　 　 　 　"=IF(SIGN(A1)=SIGN(A2),SUM(1,C1),1)"

　 　With Range("D1:D" & 終わり行)
　 　 　 　.Formula = _
　 　 　 　"=IF(SIGN(A1)<>SIGN(A2),B1/C1,"""")"
　 　 　 　.Value = .Value
　 　End With

　 　Range("B:C").Delete

Application.ScreenUpdating = True
End Sub

回答No.1

keithin

Ａ列にＡ１からデータが並んでいる。

sub macro1()
　dim ha as range
　dim i as integer
　dim s
　s = array(">=0", "<0")

　application.screenupdating = false
　range("1:2").insert shift:=xlshiftdown
　range("B:B").insert
　range("A1") = "h"

　for i = 0 to 1
　　if application.countif(range("A:A"), s(i)) > 0 then
　　　range("A:A").autofilter field:=1, criteria1:=s(i)
　　　for each ha in range("A2:a" & range("A65536").end(xlup).row).specialcells(xlcelltypevisible).areas
　　　　ha.range("B1") = application.average(ha)
　　　next
　　end if
　next i

　activesheet.autofiltermode = false
　range("1:2").delete shift:=xlshiftup
　application.screenupdating = true
end sub