| |
▼miyama さん：
こんちは
要件を取り違えていました。
結果で ０ の行の ０ を空白にするんだと思ってました。
以下、標準モジュールのロジックを、ちょっと追加。
シートモジュール側も、０なら空白にするコードが不要になります。
【標準モジュール】
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
|
|
UO3
- 10/12/18(土) 15:52 -
