Excel マクロ 平均

質問

Excel　マクロ 平均
仕事の都合で以下のようなデータの平均を出すマクロ(VBA)を作成する事になったのですが、どのようなコードになるのでしょうか？

・商品の年式ごとの平均を求める。
・金額は入っていないデータは対象外にする。
・データ数は5000件位あります。
・商品の種類は沢山あります。
・年式も様々です。
・Sheet2に実行結果の平均を入れる。

Sheet1
商品名 年式 金額
テレビ 1990 1,000
冷蔵庫 1999
テレビ 1990 2,000
冷蔵庫 1999 3,000
テレビ 1991
冷蔵庫 1990 1,000
テレビ 1991 2,000

Sheet2
　　1990　　1991 　1992 ・・・
テレビ 1,500 2,000
冷蔵庫 1,000

マクロ初心者且内容が伝わりにくい所があるかもしれませんが、何卒宜しくお願い致します。

回答No.5

ka_na_de

＃２です。

年式を
一番古い年式～一番新しい年式　まで
１年おきに計算するように変更しました。

ご参考までに。

Sub test2()
　　Dim Ws1 As Worksheet, Ws2 As Worksheet
　　Dim myRange1 As Range, myRange2 As Range
　　Dim i As Long, j As Long
　　Dim myLastRow2 As Long, myLastCol2 As Long
　　Dim myYearMax As Long, myYearMin As Long

　　Set Ws1 = Worksheets("Sheet1")
　　Set Ws2 = Worksheets("Sheet2")

　　Application.ScreenUpdating = False
　　Ws2.Cells.Clear
　　With Ws1
　　　　With .Range("A1").CurrentRegion.Resize(, 1)
　　　　　　.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
　　　　　　.SpecialCells(xlCellTypeVisible).Copy Ws2.Range("A1")
　　　　End With
　　　　Set myRange1 = .Range("A1").CurrentRegion.Offset(1, 1).Resize(, 1)
　　　　myYearMin = Application.WorksheetFunction.Min(myRange1)
　　　　myYearMax = Application.WorksheetFunction.Max(myRange1)
　　　　.ShowAllData
　　End With
　　With Ws2
　　　　.Range("A1").Clear
　　　　For j = 2 To myYearMax - myYearMin + 2
　　　　　　.Cells(1, j).Value = myYearMin + j - 2
　　　　Next j
　　　　myLastRow2 = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　myLastCol2 = .Cells(1, Columns.Count).End(xlToLeft).Column
　　　　If Ws1.AutoFilterMode Then
　　　　　　Ws1.AutoFilterMode = False
　　　　End If
　　　　For i = 2 To myLastRow2
　　　　　　For j = 2 To myLastCol2
　　　　　　　　　　With Ws1.Range("A1").CurrentRegion
　　　　　　　　　　　　.AutoFilter Field:=1, Criteria1:=Ws2.Cells(i, "A").Value
　　　　　　　　　　　　.AutoFilter Field:=2, Criteria1:=Ws2.Cells(1, j).Value
　　　　　　　　　　　　Set myRange2 = .Offset(, 2).Resize(, 1).SpecialCells(xlCellTypeVisible)
　　　　　　　　　　　　On Error Resume Next
　　　　　　　　　　　　Ws2.Cells(i, j).Value = Application.WorksheetFunction.Average(myRange2)
　　　　　　　　　　　　On Error GoTo 0
　　　　　　　　　　End With
　　　　　　Next j
　　　　Next i
　　　　Ws1.AutoFilterMode = False
　　End With
　　Application.ScreenUpdating = False

　　Set Ws1 = Nothing
　　Set Ws2 = Nothing
　　Set myRange1 = Nothing
　　Set myRange2 = Nothing
End Sub

回答No.4

nattocurry

続きです。
連続投稿が禁止されたので、時間を空けました。

With .Cells(row2, col2)
.Offset(1).Value = .Offset(1).Value + ProdPrice
.Offset(2).Value = .Offset(2).Value + 1
.Value = .Offset(1).Value / .Offset(2).Value
End With
End With

End If

row1 = row1 + 1
Loop

With Worksheets("Sheet2")

row2 = .Cells(Rows.Count, 1).End(xlUp).Row
Do Until IsEmpty(.Cells(row2, 1).Value)
With .Rows(row2).Offset(1).Resize(2)
.Hidden = True '合計金額と個数の行を非表示　表示したままにする場合はこのコードを削除
.Delete '合計金額と個数の行を削除　削除しない場合はこのコードを削除
End With
row2 = .Cells(row2, 1).End(xlUp).Row
Loop

End With

End With

End Sub

回答No.3

nattocurry

一例です。

提示サンプルではうまく動きましたが・・・

Sub test()

Dim row1 As Long 'Sheet1用 行カウンタ
Dim row2 As Long 'Sheet2用 行カウンタ
Dim col2 As Long 'Sheet2用 列カウンタ

Dim ProdName As String '商品名
Dim ProdYear As Long '年式
Dim ProdPrice As Variant '金額

Dim CellFound As Range '検索用レンジオブジェクト

row1 = 2 'Sheet1のデータの先頭行

With Worksheets("Sheet1")
Do While Application.WorksheetFunction.CountA(.Rows(row1)) 'データがある限り繰り返す

ProdName = .Cells(row1, 1).Value
ProdYear = .Cells(row1, 2).Value
ProdPrice = .Cells(row1, 3).Value

If Not IsEmpty(ProdPrice) Then '金額が空欄じゃなかったら

With Worksheets("Sheet2")
Set CellFound = .Columns(1).Find(What:=ProdName, LookAt:=xlWhole)
If CellFound Is Nothing Then
row2 = .Cells(.Rows.Count, 1).End(xlUp).Offset(3).Row
If row2 = 4 Then row2 = 2
.Cells(row2, 1).Value = ProdName
Else
row2 = CellFound.Row
End If

Set CellFound = .Rows(1).Find(What:=ProdYear, LookAt:=xlWhole)
If CellFound Is Nothing Then
col2 = .Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Column
.Cells(1, col2).Value = ProdYear
Do Until .Cells(1, col2 - 1).Value < .Cells(1, col2).Value
.Columns(col2).Cut
.Columns(col2 - 1).Insert
col2 = col2 - 1
Loop
Else
col2 = CellFound.Column
End If

文字数制限にひっかかったので、回答を分けます。

回答No.2

ka_na_de

一例です。

うまく動くといいんですが・・・

Sub test()
　　Dim Ws1 As Worksheet, Ws2 As Worksheet
　　Dim myRange As Range
　　Dim i As Long, j As Long
　　Dim myLastRow2 As Long, myLastCol2 As Long

　　Set Ws1 = Worksheets("Sheet1")
　　Set Ws2 = Worksheets("Sheet2")

　　Application.ScreenUpdating = False
　　Ws2.Cells.Clear
　　With Ws1
　　　　With .Range("A1").CurrentRegion.Resize(, 1)
　　　　　　.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
　　　　　　.SpecialCells(xlCellTypeVisible).Copy Ws2.Range("A1")
　　　　End With
　　　　With .Range("A1").CurrentRegion.Offset(, 1).Resize(, 1)
　　　　　　.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
　　　　　　.SpecialCells(xlCellTypeVisible).Copy
　　　　　　Ws2.Range("A1").PasteSpecial Transpose:=True
　　　　End With
　　　　.ShowAllData
　　End With
　　With Ws2
　　　　.Range("A1").Clear
　　　　myLastRow2 = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　myLastCol2 = .Cells(1, Columns.Count).End(xlToLeft).Column
　　　　For i = 2 To myLastRow2
　　　　　　For j = 2 To myLastCol2
　　　　　　　　　　With Ws1
　　　　　　　　　　　　If .AutoFilterMode Then
　　　　　　　　　　　　　　.AutoFilterMode = False
　　　　　　　　　　　　End If
　　　　　　　　　　　　With .Range("A1").CurrentRegion
　　　　　　　　　　　　　　.AutoFilter Field:=1, Criteria1:=Ws2.Cells(i, "A").Value
　　　　　　　　　　　　　　.AutoFilter Field:=2, Criteria1:=Ws2.Cells(1, j).Value
　　　　　　　　　　　　　　Set myRange = .Offset(, 2).Resize(, 1).SpecialCells(xlCellTypeVisible)
　　　　　　　　　　　　　　On Error Resume Next
　　　　　　　　　　　　　　Ws2.Cells(i, j).Value = Application.WorksheetFunction.Average(myRange)
　　　　　　　　　　　　　　On Error GoTo 0
　　　　　　　　　　　　End With
　　　　　　　　　　End With
　　　　　　Next j
　　　　Next i
　　　　Ws1.AutoFilterMode = False
　　End With
　　Application.ScreenUpdating = False

　　Set Ws1 = Nothing
　　Set Ws2 = Nothing
　　Set myRange = Nothing
End Sub

回答No.1

A88No8

こんにちは
　私だったら５０００件ぐらいピボットグラフで済ませてしまいますが．．
　やはりＶＢＡじゃないといけないんでしょうね(--;