Excel VBA質問箱 IV

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

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


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

8420 / 76732

←次へ　｜　前へ→


	【73886】Re:データ抽出、作成について

UO3 - 13/3/1(金) 15:50 -


	引用なし

	パスワード

▼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

371 hits

▼

【73852】データ抽出、作成について shouw 13/2/25(月) 13:00