| |
▼shouw さん：
こんにちは
とりあえず書いてみました。
・リストボックスをクリックして実行する手もありますが、操作性がおちると思われますので
別途、フォームツールのボタンを配置して、そこに以下のマクロを登録してください。
・産地や価格情報のテーブルを "マスタ" というシートに作ってください。
Ａ列が商品名、Ｂ列が産地、Ｃ列が価格です。
★しばらく、この板にこれないかもしれません。何かあれば書き込みは読めますのでアップしてください。
Sub Sample()
Dim fdt As Variant
Dim tdt As Variant
Dim com As String
Dim x As Variant
Dim c As Range
Dim stk() As Long
Dim inp() As Long
Dim sls() As Long
With ActiveSheet.DrawingObjects("List Box 1") '実際の名前に
If .ListIndex < 0 Then
MsgBox "リストから選択してから実行してください"
Exit Sub
End If
com = .List(.ListIndex)
End With
fdt = Range("B2").Value '開始日
tdt = Range("D2").Value '終了日
If Len(fdt) = 0 Or Len(tdt) = 0 Then
MsgBox "開始日、終了日をいれてから実行してください"
Exit Sub
End If
If Not IsDate(fdt) Or Not IsDate(tdt) Then
MsgBox "日付が正しくありません"
Exit Sub
End If
If fdt > tdt Then
MsgBox "開始日と終了日の関係が正しくありません"
Exit Sub
End If
With Sheets("Sheet1")
x = Application.Match(com, .Rows(1), 0)
If Not IsNumeric(x) Then
MsgBox "指定のデータがありません"
Exit Sub
End If
ReDim stk(1 To 1)
ReDim inp(1 To 1)
ReDim sls(1 To 1)
For Each c In .Range("A3", .Range("A" & .Rows.Count))
If c.Value2 < fdt Then Exit For
If c.Value2 <= tdt Then
stk(UBound(stk)) = .Cells(c.Row, x).Value
inp(UBound(inp)) = .Cells(c.Row, x + 1).Value
sls(UBound(sls)) = .Cells(c.Row, x + 2).Value
ReDim Preserve stk(1 To UBound(stk) + 1)
ReDim Preserve inp(1 To UBound(inp) + 1)
ReDim Preserve sls(1 To UBound(sls) + 1)
End If
Next
If UBound(stk) = 1 Then
MsgBox "範囲内の日付がありません"
Exit Sub
End If
ReDim Preserve stk(1 To UBound(stk) - 1)
ReDim Preserve inp(1 To UBound(inp) - 1)
ReDim Preserve sls(1 To UBound(sls) - 1)
End With
'シートにセット
Application.EnableEvents = False
Range("B6").Value = WorksheetFunction.Average(stk)
Range("C6").Value = WorksheetFunction.Max(stk)
Range("D6").Value = WorksheetFunction.Min(stk)
Range("B7").Value = WorksheetFunction.Average(inp)
Range("C7").Value = WorksheetFunction.Max(inp)
Range("D7").Value = WorksheetFunction.Min(inp)
Range("B8").Value = WorksheetFunction.Average(sls)
Range("C8").Value = WorksheetFunction.Max(sls)
Range("D8").Value = WorksheetFunction.Min(sls)
With Sheets("マスタ")
x = Application.Match(com, .Columns("A"), 0)
If IsNumeric(x) Then
Range("B10").Value = "【産地：" & .Cells(x, "B").Value & "】"
Range("C10").Value = "【価格：" & .Cells(x, "C").Value & "】"
Else
Range("B10:C10").ClearContents
End If
End With
Application.EnableEvents = True
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
