Excel VBA質問箱 IV

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

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


2441 / 13645 ツリー ←次へ | 前へ→

【67604】1つの条件で表示 miyama 10/12/17(金) 14:39 質問[未読]
【67606】Re:1つの条件で表示 Jaka 10/12/17(金) 15:19 発言[未読]
【67607】Re:1つの条件で表示 UO3 10/12/17(金) 15:47 回答[未読]
【67616】Re:1つの条件で表示 miyama 10/12/18(土) 11:41 発言[未読]
【67619】Re:1つの条件で表示 UO3 10/12/18(土) 15:52 回答[未読]
【67611】Re:1つの条件で表示 kanabun 10/12/18(土) 0:23 発言[未読]
【67617】Re:1つの条件で表示 miyama 10/12/18(土) 11:51 発言[未読]
【67618】Re:1つの条件で表示 こたつねこ 10/12/18(土) 14:30 回答[未読]
【67630】Re:1つの条件で表示 Hirofumi 10/12/19(日) 18:33 回答[未読]
【68005】Re:1つの条件で表示 miyama 11/1/25(火) 9:44 お礼[未読]

【67604】1つの条件で表示
質問  miyama  - 10/12/17(金) 14:39 -

引用なし
パスワード
   月日(a1)----企業名(b1)----商品(c1)---型式(d1)---個数(e1)
2010/4/15-----あ-----------a--------T-002-------3
2010/4/25-----あ-----------a--------T-002-------1
2010/4/15-----い-----------a--------T-003-------1
2010/4/15-----い-----------a--------T-003-------1
2010/5/15-----あ-----------b--------T-001-------1
2010/6/15-----あ-----------b--------T-001-------0
以下続く
上記はシート1です。

シート2の、s6セルに、企業名を記入したら、上記シートの個数を
足して(型式が条件です)下記のように表示したいのですが
たとえば、S6に「あ」と記入したら
シート2に
----商品(a1)---型式(b1)---個数(c1)
-----a--------T-002-------4
-----b--------T-001-------1
このようにです。個数が0(ゼロ)の場合は表示しない

申し訳ありませんご指導よろしくお願いします

【67606】Re:1つの条件で表示
発言  Jaka  - 10/12/17(金) 15:19 -

引用なし
パスワード
   ピボットテーブルをほとんど使った事がないけど、
この場合、ピボットテーブルで処理した方が簡単な様な気がします。

【67607】Re:1つの条件で表示
回答  UO3  - 10/12/17(金) 15:47 -

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

コード案です。
オブジェクト類が、ブックを閉じるまでマクロ内でNothingにできないのが
ちょっと気になりますが。
なお、Sheet1の状態は、最初にSHeet2のS6に企業コードを入れたときに記憶されます。
その後、Sheet1を変更しても反映されない構成です。もちろん、毎回、反映し直すことも
可能ですが。

【Sheet2のシートモジュール】

Private Sub Worksheet_Change(ByVal Target As Range)
 Static flag As Boolean
 Dim v()
 Dim z As Long
 
 If Target.Address(False, False) = "S6" Then
  If Not flag Then
   Call prepare
   flag = True
  End If
  If dic.exists(Target.Value) Then
   Application.EnableEvents = False
   z = Range("A" & Rows.Count).End(xlUp).Row
   If z > 1 Then Range("A2").Resize(z - 1, 3).ClearContents
   Range("A2").Resize(dic(Target.Value).Count, 3) = _
    Application.Transpose(Application.Transpose(dic(Target.Value).items))
   Application.EnableEvents = True
   z = Range("C" & Rows.Count).End(xlUp).Row
   Range("C2").Resize(z - 1).Replace What:="0", Replacement:="", LookAt:=xlWhole, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
  Else
   MsgBox "この企業は存在しません"
  End If
 End If
End Sub

【標準モジュール】

Option Explicit

Public dic As Object

Sub prepare()
 Dim c As Range
 Dim cust As String
 Dim com As String
 Dim spec As String
 Dim wk As Variant
 Dim subkey As String
 Set dic = CreateObject("Scripting.Dictionary")
 With Worksheets("Sheet1")
  For Each c In .Range("B2").Resize(.Range("B" & .Rows.Count).End(xlUp).Row)
   cust = c.Value
   com = c.Offset(, 1).Value
   spec = c.Offset(, 2).Value
   subkey = com & vbTab & spec
   If Not dic.exists(cust) Then
    Set dic(cust) = CreateObject("Scripting.Dictionary")
   End If
   If Not dic(cust).exists(subkey) Then
    dic(cust)(subkey) = Array(com, spec, 0)
   End If
   wk = dic(cust)(subkey)
   wk(2) = wk(2) + c.Offset(, 3).Value
   dic(cust)(subkey) = wk
  Next
 End With
End Sub

【67611】Re:1つの条件で表示
発言  kanabun  - 10/12/18(土) 0:23 -

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

>シート2の、s6セルに、企業名を記入したら、
その隣においた図形のボタンに登録した「btn統合_Click」マクロを
実行する例です。

'--------------------------------------- 標準モジュール
Option Explicit

Sub btn統合_Click()
 Dim WS1 As Worksheet
 Dim WS2 As Worksheet
 Dim r As Range
 Dim i As Long, k As Long, n As Long
 Dim dic As Object
 Dim v
 
 Set WS1 = Worksheets("Sheet1")
 Set WS2 = Worksheets("Sheet2")
 ' Sheet1 表範囲にオートフィルタをかけ、必要項目をSheet2に抽出
 With WS1.Range("B:B")
   Set r = Excel.Range(.Item(1), .Item(.Count).End(xlUp))
 End With
 WS1.AutoFilterMode = False
 r.AutoFilter 1, WS2.Range("S6").Value
 If r.SpecialCells(xlVisible).Count > 1 Then
   WS2.Range("A1").CurrentRegion.ClearContents
   r.Offset(, 1).Resize(, 3).Copy WS2.Range("A1")
 End If
 r.AutoFilter
 
 '統合
 Set dic = CreateObject("Scripting.Dictionary")
 With WS2.Range("A1").CurrentRegion
   With Intersect(.Cells, .Offset(1))
     v = .Value
     .ClearContents
     For i = 1 To UBound(v)
      If Not dic.Exists(v(i, 1)) Then
        k = k + 1
        dic(v(i, 1)) = k
        v(k, 1) = v(i, 1)
        v(k, 2) = v(i, 2)
        v(k, 3) = v(i, 3)
      Else
        n = dic(v(i, 1))
        v(n, 3) = v(n, 3) + v(i, 3)
      End If
     Next
     .Resize(k).Value = v
   End With
   .Sort Key1:=.Columns(1), Header:=xlYes
 End With
 Set dic = Nothing
 
End Sub

【67616】Re:1つの条件で表示
発言  miyama E-MAIL  - 10/12/18(土) 11:41 -

引用なし
パスワード
   UO3様 ありがとうございます
返事遅れました。申し訳ありません

お願いした内容で表示されました
一つお願いするとすれば、数字が「0」の場合は、その行を削除する
ことです。
申し訳ありません


【67617】Re:1つの条件で表示
発言  miyama E-MAIL  - 10/12/18(土) 11:51 -

引用なし
パスワード
   kanabun様ありがとうございます

2010/6/9----a----T-015---1
2010/6/22---a----T-007---1
2010/10/26--a----T-024---1
2010/10/27--a----T-015---2
上記の場合ですが
------------a----T-015---5
このように表示されます

以下の形で表示したいのですが
------------a----T-015---3
------------a----T-007---1
------------a----T-024---1
申し訳ありませんが、お願いいたします

【67618】Re:1つの条件で表示
回答  こたつねこ  - 10/12/18(土) 14:30 -

引用なし
パスワード
   ▼miyama さん:
Sheet2のシートモジュールにどうぞ

Private Const C_JOIN_STR  As String = vbTab

Private Sub Worksheet_Change(ByVal Target As Range)
  Const EventCellString As String = "S6"
  
  Dim EventCell  As Excel.Range
  
  Set EventCell = Range(EventCellString)
  
  If Not (Intersect(EventCell, Target) Is Nothing) Then
    Call DispTotal(EventCell.Value)
  End If
  
  If Not (EventCell Is Nothing) Then Set EventCell = Nothing
  
End Sub

Private Sub DispTotal(ByVal SearchKey As String)
  Const C_SHT_DATA As String = "Sheet1"
  Const C_SHT_POST As String = "Sheet2"
  
  Dim Ret     As Boolean
  Dim Msg     As String
  Dim Dic     As Object
  
  Set Dic = CreateObject("Scripting.Dictionary")
  
  Ret = AcquisitionData(C_SHT_DATA, SearchKey, Dic, Msg)
  
  If (Ret) Then
    Ret = PostData(C_SHT_POST, Dic, Msg)
    If (Ret = False) Then Call MsgBox(Msg, vbCritical)
  Else
    Call MsgBox(Msg, vbCritical)
  End If
  
  If Not (Dic Is Nothing) Then Set Dic = Nothing
End Sub

Private Function PostData(ByVal SheetName As String, ByRef Dic As Object, ByRef Msg As String) As Boolean
  Const C_COL_COMMODITY  As String = "A"
  Const C_COL_MODEL    As String = "B"
  Const C_COL_AMOUNT   As String = "C"
  Const C_ROW_TITLE    As Long = 1
  Const C_STR_COMMODITY  As String = "商品"
  Const C_STR_MODEL    As String = "型式"
  Const C_STR_AMOUNT   As String = "個数"
  Const C_MSG_ERR     As String = "該当するデータがありません。"
  
  Dim Ret     As Boolean
  Dim Row     As Long
  Dim Sht     As Excel.Worksheet
  Dim Val     As Variant
  Dim iii     As Long
  
  Application.EnableEvents = False
  
  Set Sht = ThisWorkbook.Sheets(SheetName)
  Row = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row
  
  '転記先クリア
  Sht.Range(C_COL_COMMODITY & C_ROW_TITLE & ":" & C_COL_AMOUNT & Row).ClearContents
  
  '表題セット
  Sht.Range(C_COL_COMMODITY & C_ROW_TITLE).Value = C_STR_COMMODITY
  Sht.Range(C_COL_MODEL & C_ROW_TITLE).Value = C_STR_MODEL
  Sht.Range(C_COL_AMOUNT & C_ROW_TITLE).Value = C_STR_AMOUNT
  
  If (1 <= Dic.Count) Then
    Row = 1
    
    For iii = 0 To Dic.Count - 1
      Row = Row + 1
      Val = Split(Dic.Keys()(iii), C_JOIN_STR)
      Sht.Range(C_COL_COMMODITY & Row).Value = Val(0)
      Sht.Range(C_COL_MODEL & Row).Value = Val(1)
      Sht.Range(C_COL_AMOUNT & Row).Value = Dic.Items()(iii)
    Next iii
    Ret = True
  Else
    Msg = C_MSG_ERR
    Ret = False
  End If
Exit_Function:
  Application.EnableEvents = True
  PostData = Ret
  Exit Function
Err_Function:
  Ret = False
  Msg = Err.Description
  Err.Clear
  Resume Exit_Function
End Function

Private Function AcquisitionData(ByVal SheetName As String, ByVal SearchKey As String, ByRef RetDic As Object, ByRef Msg As String) As Boolean
  On Error GoTo Err_Function
  Const C_ROW_START    As Long = 2
  Const C_COL_NAME    As String = "B"
  Const C_COL_COMMODITY  As String = "C"
  Const C_COL_MODEL    As String = "D"
  Const C_COL_AMOUNT   As String = "E"
  Const C_MSG_ERR     As String = "この企業のデータはありません。"
  
  Dim Ret     As Boolean
  Dim Sht     As Excel.Worksheet
  Dim Row     As Long
  Dim EndRow   As Long
  Dim PrimaryKey As String
  Dim Commodity  As String
  Dim Model    As String
  Dim Amount   As Double
  
  Set Sht = ThisWorkbook.Sheets(SheetName)
  EndRow = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row
  
  For Row = C_ROW_START To EndRow
    If (Sht.Range(C_COL_NAME & Row).Value = SearchKey) Then
      Amount = Sht.Range(C_COL_AMOUNT & Row).Value
      If Not (Amount = 0) Then
        Commodity = Sht.Range(C_COL_COMMODITY & Row).Value
        Model = Sht.Range(C_COL_MODEL & Row).Value
        PrimaryKey = Commodity & C_JOIN_STR & Model
        RetDic(PrimaryKey) = RetDic(PrimaryKey) + Amount
      End If
    End If
  Next Row
    
  If RetDic.Count = 0 Then
    Msg = C_MSG_ERR
    Ret = False
  Else
    Ret = True
  End If
Exit_Function:
  If Not (Sht Is Nothing) Then Set Sht = Nothing
  AcquisitionData = Ret
  Exit Function
Err_Function:
  Ret = False
  Msg = Err.Description
  Err.Clear
  Resume Exit_Function
End Function

【67619】Re:1つの条件で表示
回答  UO3  - 10/12/18(土) 15:52 -

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

こんちは
要件を取り違えていました。
結果で 0 の行の 0 を空白にするんだと思ってました。

以下、標準モジュールのロジックを、ちょっと追加。
シートモジュール側も、0なら空白にするコードが不要になります。

【標準モジュール】

Option Explicit

Public dic As Object

Sub prepare()
 Dim c As Range
 Dim cust As String
 Dim com As String
 Dim spec As String
 Dim wk As Variant
 Dim subkey As String
 Set dic = CreateObject("Scripting.Dictionary")
 With Worksheets("Sheet1")
  For Each c In .Range("B2").Resize(.Range("B" & .Rows.Count).End(xlUp).Row)
   cust = c.Value
   com = c.Offset(, 1).Value
   spec = c.Offset(, 2).Value
   subkey = com & vbTab & spec
   If Not dic.exists(cust) Then
    Set dic(cust) = CreateObject("Scripting.Dictionary")
   End If
   If Not dic(cust).exists(subkey) Then
    dic(cust)(subkey) = Array(com, spec, 0)
   End If
   wk = dic(cust)(subkey)
   wk(2) = wk(2) + c.Offset(, 3).Value
   If wk(2) = 0 Then
    dic(cust).Remove (subkey)
   Else
    dic(cust)(subkey) = wk
   End If
  Next
 End With
End Sub

【シートモジュール】

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
 Static flag As Boolean
 Dim v()
 Dim z As Long

 If Target.Address(False, False) = "S6" Then
  If Not flag Then
   Call prepare
   flag = True
  End If
  If dic.exists(Target.Value) Then
   Application.EnableEvents = False
   z = Range("A" & Rows.Count).End(xlUp).Row
   If z > 1 Then Range("A2").Resize(z - 1, 3).ClearContents
   MsgBox dic(Target.Value).Count
   Range("A2").Resize(dic(Target.Value).Count, 3) = _
    Application.Transpose(Application.Transpose(dic(Target.Value).items))
   Application.EnableEvents = True
  Else
   MsgBox "この企業は存在しません"
  End If
 End If
End Sub

【67630】Re:1つの条件で表示
回答  Hirofumi  - 10/12/19(日) 18:33 -

引用なし
パスワード
   面白そうなので、Dictionaryを使わないで作って見ました
抽出する、シートのシートモジュールに記述して下さい

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

  Dim strPrompt As String
  
  With Target
    If .Address(False, False) <> "S6" Then
      Exit Sub
    End If
  End With
  
  Application.EnableEvents = False
  
  strPrompt = Extraction(Worksheets("Sheet1").Range("A1"), _
                Me.Range("a1"), Me.Range("S6").Value)
  
  If strPrompt <> "" Then
    MsgBox strPrompt, vbInformation
  End If
  
  Application.EnableEvents = True
  
End Sub

Private Function Extraction(rngList As Range, rngResult As Range, vntKey As Variant) As String

  'Listのデータ列数(A列〜E列)
  Const clngColumns1 As Long = 5
  'Listの中の「企業名」と成る列位置(基準列からのB列の列Offset:1列目)
  Const clngKey As Long = 1
  
  '結果表の列数
  Const clngColumns2 As Long = 3
  
  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim vntData As Variant
  Dim lngTop As Long

  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, clngKey).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      Extraction = "データが有りません"
      GoTo Wayout
    End If
  End With
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  With rngResult
    'ヘッダを出力
    .Resize(, clngColumns2).Value _
        = rngList.Offset(, clngKey + 1).Resize(, clngColumns2).Value
    '抽出条件を出力
    .Offset(, clngColumns2).Value = rngList.Offset(, clngKey).Value
    .Offset(, clngColumns2 + 1).Value = rngList.Offset(, clngColumns1 - 1).Value
    .Offset(1, clngColumns2).Value = "=""" & vntKey & """"
    If Not IsEmpty(vntKey) Then
      .Offset(1, clngColumns2 + 1).Value = ">0"
    Else
      .Offset(1, clngColumns2 + 1).Value = "="""""
    End If
    'AdvancedFilterを実行
    rngList.Resize(lngRows + 1, clngColumns1).AdvancedFilter _
        Action:=xlFilterCopy, _
        CriteriaRange:=.Offset(, clngColumns2).Resize(2, 2), _
        CopyToRange:=.Resize(, clngColumns2), _
        Unique:=False
    '抽出条件を消去
    .Offset(, clngColumns2).Resize(2, 2).ClearContents
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, clngKey).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      If Not IsEmpty(vntKey) Then
        Extraction = "抽出するレコードが有りません"
      End If
      GoTo Wayout
    End If
    '抽出データを商品昇順の型式昇順で整列
    .Offset(1).Resize(lngRows + 1, clngColumns2).Sort _
      Key1:=.Offset(1), Order1:=xlAscending, _
      Key2:=.Offset(1, 1), Order2:=xlAscending, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=xlTopToBottom, SortMethod:=xlStroke
    'データを配列に取得
    vntData = .Offset(1).Resize(lngRows + 1, clngColumns2).Value
  End With
  
  lngTop = 1
  'Key列に就いて繰り返し
  For i = 2 To lngRows + 1
    If vntData(lngTop, 1) = vntData(i, 1) _
        And vntData(lngTop, 2) = vntData(i, 2) Then
      vntData(lngTop, clngColumns2) _
          = vntData(lngTop, clngColumns2) + vntData(i, clngColumns2)
    Else
      lngTop = lngTop + 1
      For j = 1 To clngColumns2
        vntData(lngTop, j) = vntData(i, j)
      Next j
    End If
  Next i
  
  '結果を出力
  With rngResult
    .Offset(1).Resize(lngRows, clngColumns2).ClearContents
    .Offset(1).Resize(lngTop, clngColumns2).Value = vntData
  End With
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
       
End Function

【68005】Re:1つの条件で表示
お礼  miyama  - 11/1/25(火) 9:44 -

引用なし
パスワード
   jaka様
UO3様
kanabun様
こたつねこ様
Hirofumi様

お礼遅くなり申し訳ありません
色々な方法、学ばせていただきました

ありがとうございます
感謝します

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