Excel VBA質問箱 IV

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

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


14620 / 76738 ←次へ | 前へ→

【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

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

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