| |
▼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
|
|
UO3
- 10/12/17(金) 15:47 -
