Excel VBA質問箱 IV

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

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


8420 / 76732 ←次へ | 前へ→

【73886】Re:データ抽出、作成について
発言  UO3  - 13/3/1(金) 15:50 -

引用なし
パスワード
   ▼shouw さん:

こんにちは

とりあえず書いてみました。

・リストボックスをクリックして実行する手もありますが、操作性がおちると思われますので
 別途、フォームツールのボタンを配置して、そこに以下のマクロを登録してください。
・産地や価格情報のテーブルを "マスタ" というシートに作ってください。
 A列が商品名、B列が産地、C列が価格です。

★しばらく、この板にこれないかもしれません。何かあれば書き込みは読めますのでアップしてください。

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 質問
【73853】Re:データ抽出、作成について UO3 13/2/25(月) 13:38 発言
【73854】Re:データ抽出、作成について shouw 13/2/25(月) 15:40 回答
【73856】Re:データ抽出、作成について UO3 13/2/25(月) 16:27 発言
【73857】Re:データ抽出、作成について shouw 13/2/25(月) 16:37 回答
【73859】Re:データ抽出、作成について UO3 13/2/25(月) 17:47 発言
【73869】Re:データ抽出、作成について shouw 13/2/26(火) 19:05 質問
【73877】Re:データ抽出、作成について UO3 13/2/27(水) 10:09 発言
【73884】Re:データ抽出、作成について shouw 13/2/28(木) 13:17 質問
【73886】Re:データ抽出、作成について UO3 13/3/1(金) 15:50 発言
【73887】Re:データ抽出、作成について UO3 13/3/1(金) 15:51 発言

8420 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free