Excel VBA質問箱 IV

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

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


14604 / 76734 ←次へ | 前へ→

【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
6 hits

【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 お礼

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