『ユーザーフォームの転記がうまくいきません３』（peridot）

[[20120413102254]]
 の続きです。

 >つまり、アップされた例で言うと、作業簿_SK に対する単価マスタは、３行目から１７行目までの１５行。
 >で、「余裕をみて？」１８行用意したということを言っているのかな？

 はい、その通りです。

 >仮に、単価マスタに作業簿_SKに関して、SKが１０行、SXが３行、SWが２行登録されていたとする。
 >ユーザーフォームの各行のラベルは、どうなると想定している？（SKが何行、SXが何行、SWが何行？？）

 想定としては、上記の場合だとSKが10行、SXが3行、SWが2行で計15行表示と思っています。
 「枝番」混在で入力することはないので（枝番「1」の時は「1」しか入力しない）、枝番ごとに
 入力画面は別になると想定しています。

 >準備したコードでは、この場合、あらかじめデザインされた１８行のうち、上の１５行だけを表示、
 >下の５行は非表示にして、ラベルは上から、SKが１０行、SXが３行、SWが２行　となる。
 >こうせざるを得ないのは理解してくれるかな？

 はい、了解いたしました。

 >なので、一度に、１５行までしか入力（登録）できないので、１６行以上ある場合は、２回に分けてということになる。
 >なお、フォーム表示はモーダルでもモードレスでも、どちらでもＯＫにしておいた。

 了解いたしました。ありがとうございます。
----
 完成度は、まだ６０％ぐらいだと思うけど、とりあえずコードをアップする。
 まずは、動きを確認して欲しい。（要件の取り間違えは多いと思うし、エラー頻発かもしれない。）

 その前に、準備手順を以下、メモ。

 １．cbx_Cls と cbx_No は MatchRequired を True にして。
 ２．cbx_Cls 、 cbx_No、txt_Date、CommandButton1 「以外」は　Visible を False に、Enabled も False にして。
 ３．CommandButton2、CommandButton3 の TakeFocusOnClick は　False にして。
 ４．以下のコードを、それぞれのモジュールにか貼付けるわけだけど、その際に、クラスモジュールがある。
　　ＶＢＥ画面で「挿入」の「クラスモジュール」とやると、「Class1」という名前のモジュールができる。
　　このままでもいいんだけど、コードの中で、このクラスモジュールを「clsLine」という名前で利用しているので
　　この時の画面の左の下半分のプロパティウィンドウのオブジェクト名を「clsLine」に変更してほしい。
 ５．で、このクラスモジュールに、以下のクラスモジュールコードをコピペすると、
　　'Attribute txtQty_BeforeUpdate.VB_UserMemId = &H80018201  このコードが最終的にはこのプロシジャに埋め込まれる
　　Attribute txtQty_BeforeUpdate.VB_UserMemId = &H80018201
　　この、２番目のコードが構文エラーで赤く光る。びっくりしないで、
　　・左上のプロジェクトエクスプローラの clsLine　を右クリックして、解放を選ぶ。
　　　エクスポートするかどうかを聞いてくるので「はい。（エクスポートする）」を選ぶ。
　　・で、メニューの「ファイル」->「インポート」で、でてくるダイアログの中から、今、エクスポートした
      「clsLine.cls」を選んで、「開く」をおす。これで、また、クラスモジュールが入ってくる。
　　　ここでは、先ほど赤く光ったコードはきえている。（実は、プロシジャの中に埋め込まれている）
　　★詳しいことについては、必要であれば、おいおいに。まずは、コードが動くようになることを目指そう。
 ６．で、このブックを、いったん保存して閉じ、あらためて開くと、マクロが動く環境が整う。

 （ThisWorkbook モジュール）

 Option Explicit

 Private Sub Workbook_Open()
    Call Preparation
 End Sub

 Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call CleanUp
 End Sub

 （標準モジュール）

Option Explicit

'各モジュールで共通して使うPublic変数
 Public dic As Object           'コンボボックスのリスト情報
 Public dicLine As Object       '単価マスタ上の分類コードごとの行数
 Public dicSample As Object     '箱サンプルシートに関する情報
 Public dicQty As Object        '箱サンプルシートの分類・記号（枝番付き）別の数量
 Public lineClct As Collection  'ユーザーフォームの行毎のクラス保持用コレクション
 Public maxCodeLines As Long
 Public FormLines As Long
 Public skipEvent As Boolean
 
 Sub Preparation()   'Workbook_Open での処理
    
    Set dic = CreateObject("Scripting.Dictionary")
    Set dicLine = CreateObject("Scripting.Dictionary")
    Set dicSample = CreateObject("Scripting.Dictionary")
    Set dicQty = CreateObject("Scripting.Dictionary")
    Set lineClct = New Collection
    
    Call getSample          '箱サンプルからの情報の取得
    Call GetPriceList       '単価マスタからの情報の取得

 End Sub

 Sub getSample()    '箱サンプルからのデータ取り込み
    Dim w As Variant
    Dim f As Long
    Dim e As Long
    Dim s As String
    Dim c As Range
    Dim myCls As String
    
    dicSample.RemoveAll
    dicQty.RemoveAll
    
    With Sheets("箱サンプル")
    
        For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
        
            Select Case c.Value
                Case "記号"
                    If f <> 0 Then
                        e = c.Offset(-3).Row
                        dicSample(myCls & 0) = Array(f, e)
                    End If
                        myCls = c.Offset(-1).Value
                        f = c.Offset(1).Row
                Case "データ行終了"
                    e = c.Offset(-2).Row
                    dicSample(myCls & 0) = Array(f, e)
                Case Else
                    If Len(c.Value) > 0 Then
                        dicQty(myCls & vbTab & c.Value & vbTab & c.Offset(, 1).Value) = c.Offset(, 2).Value
                    End If
                    If Len(c.Offset(, 4).Value) > 0 Then
                        dicQty(myCls & vbTab & c.Offset(, 4).Value & vbTab & c.Offset(, 5).Value) = c.Offset(, 6).Value
                    End If
            End Select
            
        Next
        
        For Each w In dicSample
            If Right(w, 1) = "0" Then
                f = dicSample(w)(0)
                e = dicSample(w)(1)
                s = w
                Mid(s, Len(s)) = 1
                dicSample(s) = .Range(.Cells(f, "A"), .Cells(e, "C")).Value
                s = w
                Mid(s, Len(s)) = 2
                dicSample(s) = .Range(.Cells(f, "E"), .Cells(e, "G")).Value
            End If
        Next
        
    End With
    
 End Sub

 Private Sub GetPriceList()
    Dim c As Range
    Dim myCode As String
    Dim myCls As String
    Dim myMedia As String
    Dim w As Variant
    Dim ww As Long
    
    With Sheets("単価マスタ")
        For Each c In .Range("B3", .Range("B" & .Rows.Count).End(xlUp))
            With c.EntireRow
                myCode = .Range("B1").Value
                myCls = .Range("J1").Value
                myMedia = .Range("C1").Value
            End With
            If dicSample.exists(myCls & 0) Then
                dicLine(myCls & 0) = dicLine(myCls & 0) + 1
                dicLine(myCls & dicLine(myCls & 0)) = myCode
                If Not dic.exists(myCls) Then Set dic(myCls) = CreateObject("Scripting.Dictionary")
                If Not dic(myCls).exists(myCode) Then
                    Set dic(myCls)(myCode) = CreateObject("Scripting.Dictionary")
                    dic(myCls)(myCode)("") = True   '媒体リストの先頭行に空白メンバを
                End If
                dic(myCls)(myCode)(myMedia) = True
            End If
        Next
    End With
    
    For Each w In dicLine
        ww = Val(StrReverse(w))
        If ww = 0 Then
            If dicLine(w) > maxCodeLines Then maxCodeLines = dicLine(w)
        End If
    Next

 End Sub

 Sub CleanUp()       'Workbook_BeforeClose での処理
    Set dic = Nothing
    Set dicLine = Nothing
    Set dicSample = Nothing
    Set dicQty = Nothing
    Set lineClct = Nothing
 End Sub

 'txtQty_n の BeforeUpdated イベント
 Sub QtyUpdated(txtQty As MSForms.TextBox)
    If skipEvent Then Exit Sub
    If Len(txtQty.Value) > 0 Then
       If Not IsNumeric(txtQty.Value) Then
           Application.OnTime Now(), "'BackFocus """ & txtQty.Name & """'"
       End If
    End If
 End Sub
 
 Sub BackFocus(tbn As String)   '数量入力エラー時の処理
    MsgBox "数量入力が正しくありません"
    With UserForm1.Controls(tbn)
        .SetFocus
        .SelStart = 0
        .SelLength = Len(.Value)
    End With
 End Sub

 'cbxMedia_n の　Changeイベント
 Sub MediaSelected(cbxMedia As MSForms.ComboBox)
    Dim i As Long
    Dim idx As Long
    Dim dicA As Object
    Dim dicB As Object
    Dim d As Variant
    Dim myCls As String
    Dim myCode As String
    Dim myMedia As String
    Dim myNo As String
    Dim dKey As String
    
    If skipEvent Then Exit Sub
    
    With UserForm1
        
        skipEvent = True
        Set dicA = CreateObject("Scripting.Dictionary")
        Set dicB = CreateObject("Scripting.Dictionary")
        myCls = .cbx_Cls.Value
        myNo = .Controls("cbx_No").Value
        myMedia = cbxMedia.Value
        idx = Split(cbxMedia.Name, "_")(1)
        myCode = .Controls("lblCode_" & idx).Caption
        dKey = myCls & vbTab & myCode & myNo & vbTab & myMedia
        If dicQty.exists(dKey) Then .Controls("txtQty_" & idx).Value = dicQty(dKey)
        
        For i = 1 To FormLines
            myMedia = .Controls("cbxMedia_" & i).Value
            If .Controls("lblCode_" & i).Visible And .Controls("lblCode_" & i).Caption = myCode Then dicA(myMedia) = True
        Next
    
        For Each d In dic(myCls)(myCode)
            If Len(d) = 0 Or Not dicA.exists(d) Then dicB(d) = True
        Next
    
        For i = 1 To FormLines
            myCode = .Controls("lblcode_" & i).Caption
            myMedia = .Controls("cbxMedia_" & i).Value
            If .Controls("lblCode_" & i).Visible And .Controls("lblCode_" & i).Caption = myCode Then .Controls("cbxMedia_" & i).List = dicB.keys
        Next
        
        skipEvent = False
        
        Set dicA = Nothing
        Set dicB = Nothing
    End With
    
 End Sub

 （ユーザーフォームモジュール）

 Option Explicit

 Private Sub UserForm_Initialize()
    Dim cls As clsLine
    Dim e As MSForms.Control
    Dim myCtrl As Object
    Dim i As Long
    
    FormLines = 0
    
    For Each myCtrl In Me.Controls
        Debug.Print myCtrl.Name
        If myCtrl.Name Like "lblCode_*" Then
            FormLines = FormLines + 1
            Set cls = New clsLine
            lineClct.Add cls
            i = Split(myCtrl.Name, "_")(1)
            cls.SetCombo Me.Controls("cbxMedia_" & i)
            Set cls.txtQty = Me.Controls("txtQty_" & i)
            Set cls = Nothing
        End If
    Next
    
    skipEvent = True
    cbx_Cls.Clear
    cbx_Cls.List = dic.keys
    skipEvent = False

 End Sub

 Private Sub UserForm_Activate()
    
    If FormLines < maxCodeLines Then
        MsgBox "フォーム上の行数が十分ではないので処理ができません" & vbLf & _
               "管理者に連絡してください"
        Unload Me
    End If
    
 End Sub

 Private Sub cbx_Cls_Change()
    Dim w As Variant
    Dim z As Long
    Dim myCls As String
    Dim myCode As String
    Dim i As Long
    
    If skipEvent Or cbx_Cls.ListIndex < 0 Then Exit Sub
    
    cbx_No.Enabled = True
    
    With CommandButton1
        .Visible = True
        .Enabled = False
    End With
        
    With CommandButton2
        .Visible = True
        .Enabled = False
    End With
    
    skipEvent = True
    cbx_No.Value = Empty
    skipEvent = False
    
    myCls = cbx_Cls.Value
    z = dicLine(myCls & 0)
    
    LineSet
    
    
 End Sub

 Private Sub cbx_No_Change()
    Dim i As Long
    Dim myCls As String
    Dim myCode As String
    Dim myMedeia As String
    Dim myNo As String
    
    If skipEvent Then Exit Sub
    
    myCls = cbx_Cls.Value
    myNo = cbx_No.Value
    
    With CommandButton1
        .Visible = True
        .Enabled = True
    End With
        
    With CommandButton2
        .Visible = True
        .Enabled = True
    End With

    Call LineEnable

End Sub

 Private Sub CommandButton1_Click()      '転記
    Dim f As Long
    Dim x As Long, y As Long
    Dim myCls As String, myCode As String, myMedia As String, myQty As String
    Dim myNo As String
    Dim i As Long
    Dim ctrl As Object
    Dim w As String
    Dim myDate As String
    Dim v As Variant
    Dim okFlag As Boolean
    Dim strCol As String
    
    myCls = cbx_Cls.Value
    myNo = cbx_No.Value
    myDate = txt_Date.Value
    
    If Not IsDate(myDate) Then
        MsgBox "日付を正しく入れてください"
        Exit Sub
    End If
    
    If Len(myCls) = 0 Or Len(myNo) = 0 Then
        MsgBox "分類、枝番　のいずれかが選択されていません"
        Exit Sub
    End If

    If myNo Mod 2 = 0 Then
        i = 2
        strCol = "E"
    Else
        i = 1
        strCol = "A"
    End If
    
    v = dicSample(myCls & i)
    
    For i = 1 To FormLines
        
        If Me.Controls("lblCode_" & i).Visible Then
            myMedia = Me.Controls("cbxMedia_" & i).Value
            myCode = Me.Controls("lblCode_" & i).Caption
            myQty = Me.Controls("txtQty_" & i).Value
            If Len(myMedia) > 0 And Len(myQty) > 0 Then
                okFlag = False
                For x = LBound(v, 1) To UBound(v, 1)
                    If v(x, 1) = myCode & myNo And v(x, 2) = myMedia Or Len(v(x, 1)) = 0 Then
                        v(x, 1) = myCode & myNo
                        v(x, 2) = myMedia
                        v(x, 3) = myQty
                        okFlag = True
                        Exit For
                    End If
                Next
                
                If Not okFlag Then
                    MsgBox "シートに以下のデータを書き込む余裕がありません" & vbLf & _
                        myCode & myNo & "/" & myMedia & "/" & myQty
                End If
            End If
        End If
    Next
    
    w = myCls & 0
    f = dicSample(w)(0)
    
    With Sheets("箱サンプル")
        .Range("F1").Value = txt_Date.Value
        .Cells(f, strCol).Resize(UBound(v, 1), UBound(v, 2)).Value = v
    End With
    
    Call LineClear
    
    MsgBox "箱サンプルへの書き込みが完了しました"
    
 End Sub

 Private Sub CommandButton2_Click()     'クリア
    Call LineClear
 End Sub

 Private Sub CommandButton3_Click()     '終了
    skipEvent = True
    Unload Me
 End Sub

 Private Sub LineSet()
    Dim x As Long
    Dim z As Long
    Dim myCls As String
    Dim myCode As String
    
    skipEvent = True
    
    myCls = cbx_Cls.Value
    z = dicLine(myCls & 0)
    
    For x = 1 To FormLines
        If x > z Then
            Me.Controls("lblCode_" & x).Visible = False
            Me.Controls("cbxMedia_" & x).Visible = False
            Me.Controls("txtQty_" & x).Visible = False
        Else
            myCode = dicLine(myCls & x)
            
            With Me.Controls("lblCode_" & x)
                .Visible = True
                .Enabled = False
                .Caption = myCode
            End With
            
            With Me.Controls("cbxMedia_" & x)
                .Visible = True
                .Enabled = False
                .List = dic(myCls)(myCode).keys
                .Value = Empty
            End With
            
            With Me.Controls("txtQty_" & x)
                .Visible = True
                .Enabled = False
                .Value = Empty
            End With
            
        End If

    Next
    
    skipEvent = False
    
 End Sub

 Private Sub LineEnable()
    Dim x As Long
    Dim z As Long
    Dim myCls As String
    
    skipEvent = True
    
    myCls = cbx_Cls.Value
    z = dicLine(myCls & 0)
    
    For x = 1 To FormLines
        If x <= z Then
            Me.Controls("lblCode_" & x).Enabled = True
            Me.Controls("cbxMedia_" & x).Enabled = True
            Me.Controls("txtQty_" & x).Enabled = True
        End If
    Next
    
    skipEvent = False
    
 End Sub

 Private Sub LineClear()
    Dim i As Long
    
    skipEvent = True
    
    With cbx_No
        .Value = Empty
        .Enabled = False
    End With
    
    For i = 1 To FormLines
    
        With Me.Controls("lblCode_" & i)
            .Caption = Empty
            .Visible = False
        End With
        
        With Me.Controls("cbxMedia_" & i)
            .Value = Empty
            .Clear
            .Visible = False
        End With

        With Me.Controls("txtQty_" & i)
            .Value = Empty
            .Visible = False
        End With
        
    Next
    
    txt_Date.Value = Empty
    cbx_Cls.Value = Empty
    
    With CommandButton1
        .Visible = True
        .Enabled = False
    End With
        
    With CommandButton2
        .Visible = True
        .Enabled = False
    End With

    skipEvent = False
 
 End Sub

 （クラスモジュール）

 Option Explicit

 Dim WithEvents cbxMedia As MSForms.ComboBox

 Private Declare Function ConnectToConnectionPoint& _
    Lib "shlwapi" Alias "#168" _
    (ByVal punk&, ByVal riidEvent&, ByVal fConnect&, _
     ByVal punkTarget&, ByVal pdwCookie&, ByVal ppcpOut&)
 Private mCookie&
 Private mCtl As MSForms.TextBox

 Private Sub Class_Terminate()
    If mCookie = 0 Then Exit Sub
    ConnectEvent False
    mCookie = 0
 End Sub

 Property Set txtQty(ByVal m As MSForms.TextBox)
    Set mCtl = m
    ConnectEvent True
 End Property

 Property Get txtQty() As MSForms.TextBox
    Set txtQty = mCtl
 End Property

 Sub SetCombo(cb As MSForms.ComboBox)
    Set cbxMedia = cb
 End Sub

 Private Sub ConnectEvent(ByVal f As Boolean)
    Dim iid&(3)
    'IID_IDispatch
    iid(0) = &H20400
    iid(2) = &HC0
    iid(3) = &H46000000
    ConnectToConnectionPoint ObjPtr(Me), _
        VarPtr(iid(0)), f, ObjPtr(mCtl), VarPtr(mCookie), 0&
 End Sub

 Private Sub cbxMedia_Change()    'cbxMedia_n のChangeイベント
    Call MediaSelected(cbxMedia)
 End Sub

 Public Sub txtQty_BeforeUpdate(ByVal Cancel As ReturnBoolean)   'txtQty_n のBeforeUpdateイベント
'Attribute txtQty_BeforeUpdate.VB_UserMemId = &H80018201  このコードが最終的にはこのプロシジャに埋め込まれる
 Attribute txtQty_BeforeUpdate.VB_UserMemId = &H80018201
    Call QtyUpdated(txtQty)
 End Sub

 (ぶらっと)
----
 (ぶらっと)様

 ありがとうございます。

 …いきなりつまづきました…
 ユーザーフォームを表示したところ、「分類」（cbx_Cls）で何も表示されません…

 コントロールのプロパティやクラスモジュールの設定は書かれたとおりにしました。

 単価マスタのが、2行目が見出しで3行目からデータなので

                myCode = .Range("B2").Value
                myCls = .Range("J2").Value
                myMedia = .Range("C2").Value

 このようにしてみましたがダメでした…

 シート名なども確認しました。
 A51には「データ行終了」と入れています。

 どこがいけないんでしょう…

 (peridot)
----
 指摘のコードは、With c.EntireRow　をうけているので、B1,J1,C1 にもどして。

 とくに説明はしなかったけど、対象の分類は、箱サンプルシートから抽出してきている。
 ここになければ、単価マスタにあっても対象外にしている。箱サンプルシートにないものを
 仮にあつかったとしても、最終的に箱シートを更新できないよね。そちらの箱サンプルシートはどうなっている？
 一応、こちらでは、ざらっと流してみて、私が予期した動きにはなっているんだけど、何か、こちらで勘違いしてるかな？

 あと、コードとしては未手当のところも残っていて、それは、最後にいれこもうと考えているんだけど
 たとえば箱サンプルシートの合計。要件が、まだ把握しきれていないということもあるんだけど、
 とりあえず、記号には、数字は含まないと考えていい？
 それとも記号自体に A1 とか BB3 といったものがありうる？
 次に枝番だけど、1,2,・・・9,10,11・・・　と想定してる。 01,02,03,・・・・は想定していないけど、それでいい？

 (ぶらっと)
----
 >指摘のコードは、With c.EntireRow　をうけているので、B1,J1,C1 にもどして。
 了解いたしました。

 今試したところ、「分類」の表示までうまくいきました。
 昨日はもしかしたら「保存」→「閉じる」→「開く」がちゃんとできていなかったのかも…
 （やったつもりでしたが）

 で、今度は枝番が表示されないのですが、ここはこちらで

    UserForm4.cbx_No.List = Array("", "1", "2", "3", "4")

 このようなコードを入れてもよいのでしょうか。
 （枝番が出て来なくて先に進めないので）

 とりあえず上記のコードを入れると「記号」が表示されました。
 そこで「媒体」(cbx_Media)を選ぼうとすると
 「メソッドまたはメンバーが見つかりません」のエラーが出ます。
 エラーの箇所は

 'cbxMedia_n の　Changeイベント
 Sub MediaSelected(cbxMedia As MSForms.ComboBox)

 です。
 それで一旦VBE画面を閉じて再度ユーザーフォームを開こうとすると、次から
 「実行時エラー 91
 オブジェクト変数またはWithブロックが定義されていません」
 のエラーが出ます。
 場所は  Private Sub UserForm_Initialize() の
             lineClct.Add cls
 です。

 箱サンプルのレイアウトは、前トピの冒頭に書いたものに、A51に「データ行終了」を入れたものです。
 （データ部分は空白にしています）

 >とりあえず、記号には、数字は含まないと考えていい？

 今のところ含まれていません。
 ただ、今後も絶対に含まれないという可能性は分かりません…
 新しい商品が出るたびにコードも増えるので…

 枝番は　1,2... で想定しています。
 現状では最大でも（それもごく稀に）3までしか出ていないとのことですが、念のために4まで用意しています。

 上のエラーは私が勝手にコードを追加したからでしょうか…

 (peridot)
----
 ちょっと風邪でダウン中で、対応遅れ、申し訳なし。
 まだ、寝込んでいるんだけど、とりあえず。

 >で、今度は枝番が表示されないのですが、ここはこちらで
 >UserForm4.cbx_No.List = Array("", "1", "2", "3", "4")
 >このようなコードを入れてもよいのでしょうか。

 ここには、あらかじめRowSourceでリストをしていしているのかと思っていた。
 当方のテストでは、アップしたコードからは消したけど、同じようなコードを
 Initializeルーティンにいれて実行していた。

 >そこで「媒体」(cbx_Media)を選ぼうとすると
 >「メソッドまたはメンバーが見つかりません」のエラーが出ます。
 >エラーの箇所は

 >'cbxMedia_n の　Changeイベント
 >Sub MediaSelected(cbxMedia As MSForms.ComboBox)

 これについてのコメントは後回しにする。
 このようにエラーが発生すると、プロジェクト（このブックのＶＢＡコードの全体）が
 ｢リセット｣される。そうすると、パブリック変数、モジュールレベル変数も、すべてがリセット
 されるので、オブジェクト変数の中身もNothingになってしまっている。
 だから、実行時エラー 9　等になる。
 一度、ブックを閉じて再度読み込むか、あるいは（めんどくさいよね、それじゃ）Workbook_Openの
 任意のところをクリックして、メニューの実行で実行させて。

 ★とにかく、分類まではでたようなのでよかった。
   ところで、cbx_Media なの？？？　こちらのコードでは cbxMedia_n にしてるけど。
   （lblCode_n yxyQty_n も同様）
   そちらのフォームでは cbx_Mediq_n ？？
   もしそうなら、フォームを直すか、コードを直すか。どちらにする？
 
 で、記号に数字があるかどうかを聞いたのは、意図としては、右側に集約するとき
 SK1 SK2 は SK に集約、これは明白？　もし、元の記号がSKではなく、SK1 だったり、SK2 だったり。
 そうすると、SK1で集約、SK2で集約。そうする必要があるので、さぁ、どうしようかなと悩んでいて
 ちょっと聞いていたもの。まぁ、先のことなので、集約ルールについては、そちらでも、じっくりと
 考えておいてほしい。

 (ぶらっと)
----
 枝番は  Private Sub UserForm_Initialize() に上記コードを入れていました。
 コンボボックスのプロパティだと、セル範囲しか指定できないんですよね？（違ってたらすみません）
 特に指定するためのセルを設ける必要もないかと思って…

 >ところで、cbx_Media なの？？？　こちらのコードでは cbxMedia_n にしてるけど。

 すみません、書き間違えました。
 cbxMedia_nです。

 >SK1 SK2 は SK に集約、これは明白？

 はい、そうです。
 全ての記号（A列やE列の記号）は「記号+枝番」で、合計欄では「記号」のみになります。
 元々、「サンプル記号」というのがあり（SK、VAといったもの）、それが何回目のデータ受信でデータを受けたかによって枝番がつきます。
 2回目のデータ受信で件数が発生したものについては「記号：SK2、媒体：KK」というようにデータ受信回数の番号が記号の後に振られるので、
 1回目のデータ受信にその「記号＆媒体」の組合せがなければ「SK1」が無く「SK2」だけがある、ということもあります。
 そして、一日を通して同じ「記号＆媒体」の組合せのものの件数がどれだけ来たかを合計します。
 この時に「SK1/KK/20件」「SK2/KK/100件」「SK3/KK/15」と有ったら合計は「SK/KK/135件」と集約されます。

 記号に数字があるかどうか、で私が「今後発生するかも…」とお答えしたのは、この「記号」自体に例えば
 「A1」という記号が出来て、「A11」「A12」となるかもしれない、ということでした。

 なんかややこしくてすみません…

 ※お風邪、お大事になさってください

 (peridot)
----
 枝番コンボボックスについては、そちらの手当でOK。

 cbxMedia_n については、調べてみるけど・・・・
 これは、最初から、エラーなく、ここにたどり着いたときにも、ここで「メソッドまたはメンバーが見つかりません」
 こうなるということ？

 記号については、後回しでいいんだけど、何を言いたいかというと
 今、SKは、｢今あるSK｣だと、頭にこびりついているから、なかなかぴんとこないかもしれないけど
 例に挙げてくれたA1　で説明すると　A11 A12 こんなものがあって、これを A1 で集約。
 処理としてはこうなるんだけど、これを実現するロジックをどうしようかと考えている。（悩んでいる）
 もしかしたら、オリジナルの記号は｢A｣だったかもしれない。で、枝番の｢11｣｢12｣がついているのかもしれない。
 さぁ、A で集約しようか、A1 で集約しようか？　どうしたらいい？
 もし、記号は｢絶対に２桁｣ということならOKなんだけど？

 (ぶらっと)
----
 今、そちらで書いたと思われる、
UserForm4.cbx_No.List = Array("", "1", "2", "3", "4")
これを、こちらのコードにも書いておこうとして気がついた。
実際のユーザーフォームは、｢UserForm4｣なのかな？

 こちらがアップしたコードの中では標準モジュールの BackFocusとMediaSelectedの２カ所で
　UserForm1 という記述をしている。これを UserForm4　に変えて欲しい。
 「メソッドまたはメンバーが見つかりません」のエラーは、おそらく、これが原因。

 (ぶらっと)


----
 UserForm1をUserForm4に変えてもらえば、そちらでも動くようになると思うし
 そうなれば、ゴールも近いかな？

 なので、上で聞いている、記号の集約ルール（コードはこちらで考えるので、文章として）
 を考えておいて欲しいのと、あと１点。

 こちらで勝手に、媒体を選んだら、記号(枝番つき) + 媒体で箱サンプルデータの記載があれば、その数字を
 テキストボックスにもってくるようにしている。でも、こちらでテストしてて、この機能にあまり
 意味は無いのではと思えてきた。（重複している場合は、上書きになるんだけど、それを、操作者に
 書き込み前に認識してもらう方策として、こんな勝手な機能をつけた）

 ・もし、おもしろい機能なので残そうということなら、箱サンプル更新後、この機能で使っている元ネタテーブルも
　更新しなきゃいけないので、そこを追加する。
 ・もし、こんな機能、不要ということなら、この機能をばっさり、コードから削除することが必要。

 いずれにしても、コードを改訂しなきゃいけないので、どちらがいいか、教えてね。

 (ぶらっと)
----
 > さぁ、A で集約しようか、A1 で集約しようか？　どうしたらいい？
 > もし、記号は｢絶対に２桁｣ということならOKなんだけど？

 今のところ記号は全部2ケタですが、今後絶対に3ケタ以上にならないという保証がなくて…
 ただ、枝番が2ケタになるのはあり得ないので、「右一文字を除外」ということでは難しいでしょうか？

 UserForm1はUserForm4に変えました。

 しかし今度は別のエラーが出ました。
 「日付」→「分類」→「枝番」を選んでいってラベルに記号が表示されるまでは行きました。
 そこで cbxMedia_1 を選んでカーソルを移動する瞬間に「プロパティの値が無効です」のエラーが延々と出ます…

 上に書かれていた Enabled と Visible は両方とも False にしています。

 「デバッグ」画面が出るのではなく、Microsft Forms のメッセージボックスが出ます。

 上記の2点以外は初期値からいじっていないはずなんですが…

 テキストボックスの上書きの件は
・もし、おもしろい機能なので残そうということなら、箱サンプル更新後、この機能で使っている元ネタテーブルも
　更新しなきゃいけないので、そこを追加する。
 こちらでお願いします。
 追加変更もあると思うので…

 (peridot)
 
 
----
 >枝番が2ケタになるのはあり得ないので、「右一文字を除外」

 了解。（以前、２桁になる可能性あるっていってた記憶があったんだけど、ないんだね？）

 >テキストボックスの上書きの件は・・・・こちらでお願いします。

 了解。

 で、本題だよね。とにかく、こちらで、問題なく動くと言うことは、コードというより
 コードの記述と実際の環境（設定）の不整合ということなので、これも調べてみるけど
 コンボボックス関係で「プロパティの値が無効です」 のエラーがでるのは、MatchRequiredをTrueにして、
 なおかつ、そこにない値を入力した場合が多い。
 たけど、今回は　Initialize ルーティンに　 cbx_No.List = Array("", "1", "2", "3", "4")　を記述し
 操作としては、そのリストから何かを選んだんだよね？
 それと、｢延々と｣という表現の意味を教えてくれる？
 通常は、リストにない値を入力したとき、１度でるけど、正しいものを選び直せばでなくなるけど？

 (ぶらっと)

----
 >以前、２桁になる可能性あるっていってた記憶があったんだけど、ないんだね
 はい。データ受信回数自体が2ケタになること自体が無いということなので、1ケタで大丈夫です。

 それで、コンボボックスのエラーですが、cbx_No.List = Array("", "1", "2", "3", "4")を記述して、
 その中から選びました。
 そして「媒体」(cbxMedia_n)をクリックするとプルダウンに「単価マスタ」にあるリストが表示されるんですが、
 それのどれを選んでも「プロパティの…」のエラーが出ます。
 そして、ユーザーフォームのどこをクリックしても、「媒体」の値をクリアしても、何かの操作
 （他のコントロールをクリックするとか、右上の×ボタンでユーザーフォームを閉じようとするとか）を
 する度に「プロパティの…」のエラーが出続けます。
 （エラーが出た後、閉じようとすればフォームを閉じることはできます）

 cbxMedia_n のプロパティでMatchRequiredをFalseにするとエラーは回避できますが、これでは単価マスタに
 ない値でも入力できてしまうので、それは避けたいです。
 （現在でも大文字小文字・全角半角を混在して入力してデータ集計の時に困ることがあるので…）

 単価マスタの
 　　A　　　B　　　　C　　　　D　　　　E　　　F　　　　G　　　　H　　　　I　　　　J
 1　単価表　
 2　　　　記号　　媒体名　基本単価　追加分　付帯業務　区分　基本コスト　単価　　　分類

 A1の「単価表」の見出しがA1〜C1まで結合してあるのが原因かと思って結合を解除しましたが変わりません。

 >リストにない値を入力したとき、１度でるけど、正しいものを選び直せばでなくなるけど？
 正しいものが表示されていてそれを選んでいるつもりなんですが…
 他にプロパティの設定が間違っているのでしょうか…

 (peridot)
----
 >cbxMedia_n のプロパティでMatchRequiredをFalseにするとエラーは回避できますが、これでは単価マスタに
 >ない値でも入力できてしまうので、それは避けたいです。

　えっ？ここは MatchRequired = False で、そのかわりに、Style を　2 にするんじゃなかった？
　なかなか、考えたもんだと、感心したんだけど？　リストに表示しているものは、空白値と単価マスタにあるもののみ。
　で、入力できない仕掛けなので、リストにあるもの（あるいは選択の取り消しのための空白）しか選べないと
　これは、そちらで考えた仕様だけど？

　忘れているのかもしれないけど、媒体を選ぶと、同じ記号のリストボックスのリストからは、その媒体を消してしまう。
　そうすると、リストにないものが選ばれている状態になる。だから MatchRequired は False 。
　そちらからの要求でいれた仕様だけど忘れたのかな？

 (実は、アップしたコードは、同じ記号じゃなくても選ばれた媒体コードを消てしまっているというバグを含んでいるんだけど
　それは最後に修正しようと思っている）

 (ぶらっと)
----
 >　えっ？ここは MatchRequired = False で、そのかわりに、Style を　2 にするんじゃなかった？ 
 >　なかなか、考えたもんだと、感心したんだけど？
 すみません、確かBun様と並行してお教えいただいてた時に「MatchRequired = True 、Style = 0 がいい」と言われたのでそのままにしてました！

 すみませんでした…orz

 > Listに無い物しか入力出来ない様にするなら、CommandButtonを押して転記する時どの道、
 > ComboBox4〜11の入力確認を行うでしょうから、其の時ListIndexが-1かどうか確認すればいい事と思います
 > 何故なら、ComboBoxのTextBox部に入力が在っても其の値がComboBoxのListに無ければListIndexは-1なのですから
 > 逆に空白行を入れると此れが出来なくなります
 > 因って、「コントロールのプロパティでStyleを「2」にして」もやめた方がいいし、
 > 此れをやらなければ、空白行をListに入れる必要も無いと思います

 これをずっとそのままにしてたので…

 お手数をおかけしました…エラー出なくなりました。

 先程ユーザーフォーム呼び出し時に

 Private Sub UserForm_Initialize()


    For Each myCtrl In Me.Controls
        Debug.Print myCtrl.Name
        If myCtrl.Name Like "lblCode_*" Then
            FormLines = FormLines + 1
            Set cls = New clsLine
            lineClct.Add cls　　　　　　　　　'←ここ
            i = Split(myCtrl.Name, "_")(1)
            cls.SetCombo Me.Controls("cbxMedia_" & i)
            Set cls.txtQty = Me.Controls("txtQty_" & i)
            Set cls = Nothing
        End If
    Next
 上記部分で「オブジェクトまたはWithブロックが定義されていません」のエラーが出ましたが、一旦ブックを閉じて
 開きなおすとエラーは出ませんでした。

 それで、シートへの転記うまくいきました！

 あとは書いておられるように、「作業簿_KK」のように「記号」がそれぞれ違う場合に「媒体」が消されてしまう現象は起きています。

 とにかく「プロパティの〜」はこちらの思い込み＆設定ミスでした
 申し訳ございませんでした…

 (peridot)
----
 進捗したようでよかったね。。
で、これから、仕様の勘違い等も含めたバグつぶしが始まるわけで、それが全て完了してからと
思っていたけど、一応、以下の機能を加味したコードをアップしておく。
（コード全てではなく、改訂したプロシジャ単位でアップするので、いれかえ、ないしは追加してね）

 ・箱サンプルの合計欄自動生成（仕様追加）
 ・箱サンプル更新後の、数量データ取得（仕様追加）
 ・媒体を選択した際に削除するリストを、同じ記号のものに限定。（バグ対応）

 (標準モジュール)  

 Sub Preparation()   'Workbook_Open での処理
    
    Set dic = CreateObject("Scripting.Dictionary")
    Set dicLine = CreateObject("Scripting.Dictionary")
    Set dicSample = CreateObject("Scripting.Dictionary")
    Set dicQty = CreateObject("Scripting.Dictionary")
    Set lineClct = New Collection
    
    Call getSample          '箱サンプルからの情報の取得
    Call GetPriceList       '単価マスタからの情報の取得
    Call GetQtyInfo         '箱サンプルから数量マトリックスの取得
 End Sub

 Sub getSample()    '箱サンプルからのデータ取り込み
    Dim w As Variant
    Dim f As Long
    Dim e As Long
    Dim s As String
    Dim c As Range
    Dim myCls As String
    
    dicSample.RemoveAll
    dicQty.RemoveAll
    
    With Sheets("箱サンプル")
    
        For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
        
            Select Case c.Value
                Case "記号"
                    If f <> 0 Then
                        e = c.Offset(-3).Row
                        dicSample(myCls & 0) = Array(f, e)
                    End If
                        myCls = c.Offset(-1).Value
                        f = c.Offset(1).Row
                Case "データ行終了"
                    e = c.Offset(-2).Row
                    dicSample(myCls & 0) = Array(f, e)
                Case Else
                    If Len(c.Value) > 0 Then
                        dicQty(myCls & vbTab & c.Value & vbTab & c.Offset(, 1).Value) = c.Offset(, 2).Value
                    End If
                    If Len(c.Offset(, 4).Value) > 0 Then
                        dicQty(myCls & vbTab & c.Offset(, 4).Value & vbTab & c.Offset(, 5).Value) = c.Offset(, 6).Value
                    End If
            End Select
            
        Next
        
    End With
    
 End Sub

 'cbxMedia_n の　Changeイベント
 Sub MediaSelected(cbxMedia As MSForms.ComboBox)
    Dim i As Long
    Dim idx As Long
    Dim dicA As Object
    Dim dicB As Object
    Dim d As Variant
    Dim myCls As String
    Dim myCode As String
    Dim myMedia As String
    Dim myNo As String
    Dim dKey As String
    
    If skipEvent Then Exit Sub
    
    With UserForm4
        
        skipEvent = True
        Set dicA = CreateObject("Scripting.Dictionary")
        Set dicB = CreateObject("Scripting.Dictionary")
        myCls = .cbx_Cls.Value
        myNo = .Controls("cbx_No").Value
        myMedia = cbxMedia.Value
        idx = Split(cbxMedia.Name, "_")(1)
        myCode = .Controls("lblCode_" & idx).Caption
        dKey = myCls & vbTab & myCode & myNo & vbTab & myMedia
        If dicQty.exists(dKey) Then .Controls("txtQty_" & idx).Value = dicQty(dKey)
        
        For i = 1 To FormLines
            myMedia = .Controls("cbxMedia_" & i).Value
            If .Controls("lblCode_" & i).Visible And .Controls("lblCode_" & i).Caption = myCode Then dicA(myMedia) = True
        Next
    
        For Each d In dic(myCls)(myCode)
            If Len(d) = 0 Or Not dicA.exists(d) Then dicB(d) = True
        Next
    
        For i = 1 To FormLines
            myMedia = .Controls("cbxMedia_" & i).Value
            If .Controls("lblCode_" & i).Visible And .Controls("lblCode_" & i).Caption = myCode Then .Controls("cbxMedia_" & i).List = dicB.keys
        Next
        
        skipEvent = False
        
        Set dicA = Nothing
        Set dicB = Nothing
    End With
    
 End Sub

 Sub GetQtyInfo()     '★追加
    Dim w As Variant
    Dim f As Long
    Dim e As Long
    Dim s As String

    With Sheets("箱サンプル")
        For Each w In dicSample
           If Right(w, 1) = "0" Then
               f = dicSample(w)(0)
               e = dicSample(w)(1)
               s = w
               Mid(s, Len(s)) = 1
               dicSample(s) = .Range(.Cells(f, "A"), .Cells(e, "C")).Value
               s = w
               Mid(s, Len(s)) = 2
               dicSample(s) = .Range(.Cells(f, "E"), .Cells(e, "G")).Value
           End If
        Next
    End With
    
 End Sub

 Sub QtyTotal()     '★追加
    Dim w As Variant
    Dim f As Long
    Dim e As Long
    Dim dicW As Object
    Dim i As Long
    Dim j As Long
    Dim myCode As String
    Dim myMedia As String
    Dim myQty As Long
    Dim dKey As String
    Dim v As Variant
    
    Set dicW = CreateObject("Scripting.Dictionary")
    
    With Sheets("箱サンプル")
        For Each w In dicSample
            If Right(w, 1) = "0" Then
                f = dicSample(w)(0)
                e = dicSample(w)(1)
                dicW.RemoveAll
                For j = 1 To 5 Step 4
                    For i = f To e
                        myCode = .Cells(i, j).Value
                        If Len(myCode) > 0 Then
                            myCode = Left(myCode, Len(myCode) - 1)
                            myMedia = .Cells(i, j + 1).Value
                            myQty = Val(.Cells(i, j + 2).Value)
                            dKey = myCode & vbTab & myMedia
                            If Not dicW.exists(dKey) Then dicW(dKey) = Array(myCode, myMedia, 0)
                            v = dicW(dKey)
                            v(2) = v(2) + myQty
                            dicW(dKey) = v
                        End If
                    Next
                Next
                With .Range(.Cells(f, "J"), .Cells(e, "L"))
                    .ClearContents
                    .Resize(dicW.Count).Value = WorksheetFunction.Transpose( _
                        WorksheetFunction.Transpose(dicW.items))
                End With
            End If
        Next
    End With
    
    Set dicW = Nothing
    
 End Sub

 (ユーザーフォームモジュール)

 Private Sub UserForm_Initialize()
    Dim cls As clsLine
    Dim e As MSForms.Control
    Dim myCtrl As Object
    Dim i As Long
    
    FormLines = 0
    
    For Each myCtrl In Me.Controls
        Debug.Print myCtrl.Name
        If myCtrl.Name Like "lblCode_*" Then
            FormLines = FormLines + 1
            Set cls = New clsLine
            lineClct.Add cls
            i = Split(myCtrl.Name, "_")(1)
            cls.SetCombo Me.Controls("cbxMedia_" & i)
            Set cls.txtQty = Me.Controls("txtQty_" & i)
            Set cls = Nothing
        End If
    Next
    
    cbx_No.List = Array("", "1", "2", "3", "4")
    
    skipEvent = True
    cbx_Cls.Clear
    cbx_Cls.List = dic.keys
    skipEvent = False

 End Sub

 Private Sub CommandButton1_Click()      '転記
    Dim f As Long
    Dim x As Long, y As Long
    Dim myCls As String, myCode As String, myMedia As String, myQty As String
    Dim myNo As String
    Dim i As Long
    Dim ctrl As Object
    Dim w As String
    Dim myDate As String
    Dim v As Variant
    Dim okFlag As Boolean
    Dim strCol As String
    
    myCls = cbx_Cls.Value
    myNo = cbx_No.Value
    myDate = txt_Date.Value
    
    If Not IsDate(myDate) Then
        MsgBox "日付を正しく入れてください"
        Exit Sub
    End If
    
    If Len(myCls) = 0 Or Len(myNo) = 0 Then
        MsgBox "分類、枝番　のいずれかが選択されていません"
        Exit Sub
    End If

    If myNo Mod 2 = 0 Then
        i = 2
        strCol = "E"
    Else
        i = 1
        strCol = "A"
    End If
    
    v = dicSample(myCls & i)
    
    For i = 1 To FormLines
        
        If Me.Controls("lblCode_" & i).Visible Then
            myMedia = Me.Controls("cbxMedia_" & i).Value
            myCode = Me.Controls("lblCode_" & i).Caption
            myQty = Me.Controls("txtQty_" & i).Value
            If Len(myMedia) > 0 And Len(myQty) > 0 Then
                okFlag = False
                For x = LBound(v, 1) To UBound(v, 1)
                    If v(x, 1) = myCode & myNo And v(x, 2) = myMedia Or Len(v(x, 1)) = 0 Then
                        v(x, 1) = myCode & myNo
                        v(x, 2) = myMedia
                        v(x, 3) = myQty
                        okFlag = True
                        Exit For
                    End If
                Next
                
                If Not okFlag Then
                    MsgBox "シートに以下のデータを書き込む余裕がありません" & vbLf & _
                        myCode & myNo & "/" & myMedia & "/" & myQty
                End If
            End If
        End If
    Next
    
    w = myCls & 0
    f = dicSample(w)(0)
    
    Application.ScreenUpdating = False
    
    With Sheets("箱サンプル")
        .Range("F1").Value = txt_Date.Value
        .Cells(f, strCol).Resize(UBound(v, 1), UBound(v, 2)).Value = v
    End With
    
    Call QtyTotal
    
    Application.ScreenUpdating = True
    
    Call LineClear
    Call GetQtyInfo
    
    MsgBox "箱サンプルへの書き込みが完了しました"
    
 End Sub

 (ぶらっと)
----
 ぶらっと様

 ありがとうございます。

 コードを追加・変更いたしました。
 すると、ユーザーフォームにデータを入力してコマンドボタン1を押すと

  Sub QtyTotal() の

                    .Resize(dicW.Count).Value = WorksheetFunction.Transpose( _
                        WorksheetFunction.Transpose(dicW.items))

 ここの部分で「型が一致しません」のエラーになります。（シートへの転記自体はできてます）

 その後、再度ユーザーフォームを開こうとすると前に書きました

 Private Sub UserForm_Initialize()
 



    For Each myCtrl In Me.Controls
        Debug.Print myCtrl.Name
        If myCtrl.Name Like "lblCode_*" Then
            FormLines = FormLines + 1
            Set cls = New clsLine
            lineClct.Add cls　　　　　　　　　'←ここ
            i = Split(myCtrl.Name, "_")(1)
            cls.SetCombo Me.Controls("cbxMedia_" & i)
            Set cls.txtQty = Me.Controls("txtQty_" & i)
            Set cls = Nothing
        End If
    Next
 上記部分で「オブジェクトまたはWithブロックが定義されていません」のエラーが頻発します。
 (ブックを保存して開きなおすと最初は出ませんが、ユーザーフォームでエラーになった後だと出続けます）

 合計欄はちゃんと合計されてます。

 「型が一致しません」は何の型が違うのでしょうか

 (peridot)
----
 「型が一致しません」については、今から調べてみるね。

 で、いったんエラーになった後のことだけで、上のほうでも述べたように、エラーになって、
 もういいやということで「終了」をクリックすると、「ＶＢＡコード一式」が「リセット」される。
 ということは、各種変数が初期値に戻るということで、ブック読み込み時に自動的にセットしていた
 諸々の変数がNothingになってしまうので、これを復旧しなきゃいけない。
 方法は、ブックを閉じて、開きなおすか、あるいは、ブックが開かれた時、Workbook_Openでやっていることは
 標準モジュールの「Preparation」を実行しているだけなので、閉じて開きなおさなくても
 ツール->マクロ->マクロ で　「Preparation」を実行させても、復旧するよ。

 (ぶらっと)
 
----
 型が一致しません　の件、原因は、合計すべきものが何も無い空っぽの場合のバグ。
 （転記された分類の合計のみを変更すればよかったんだけど、面倒なので、全ての合計を作り直していて
　他の分類で、データが無い場合にエラーというおそまつ！！）

 ついでに転記された分類のみの合計作成に変えた。以下の２つのプロシジャいれかえお願い。

 Private Sub CommandButton1_Click()      '転記
    Dim f As Long
    Dim x As Long, y As Long
    Dim myCls As String, myCode As String, myMedia As String, myQty As String
    Dim myNo As String
    Dim i As Long
    Dim ctrl As Object
    Dim w As String
    Dim myDate As String
    Dim v As Variant
    Dim okFlag As Boolean
    Dim strCol As String
    
    myCls = cbx_Cls.Value
    myNo = cbx_No.Value
    myDate = txt_Date.Value
    
    If Not IsDate(myDate) Then
        MsgBox "日付を正しく入れてください"
        Exit Sub
    End If
    
    If Len(myCls) = 0 Or Len(myNo) = 0 Then
        MsgBox "分類、枝番　のいずれかが選択されていません"
        Exit Sub
    End If

    If myNo Mod 2 = 0 Then
        i = 2
        strCol = "E"
    Else
        i = 1
        strCol = "A"
    End If
    
    v = dicSample(myCls & i)
    
    For i = 1 To FormLines
        
        If Me.Controls("lblCode_" & i).Visible Then
            myMedia = Me.Controls("cbxMedia_" & i).Value
            myCode = Me.Controls("lblCode_" & i).Caption
            myQty = Me.Controls("txtQty_" & i).Value
            If Len(myMedia) > 0 And Len(myQty) > 0 Then
                okFlag = False
                For x = LBound(v, 1) To UBound(v, 1)
                    If v(x, 1) = myCode & myNo And v(x, 2) = myMedia Or Len(v(x, 1)) = 0 Then
                        v(x, 1) = myCode & myNo
                        v(x, 2) = myMedia
                        v(x, 3) = myQty
                        okFlag = True
                        Exit For
                    End If
                Next
                
                If Not okFlag Then
                    MsgBox "シートに以下のデータを書き込む余裕がありません" & vbLf & _
                        myCode & myNo & "/" & myMedia & "/" & myQty
                End If
            End If
        End If
    Next
    
    w = myCls & 0
    f = dicSample(w)(0)
    
    Application.ScreenUpdating = False
    
    With Sheets("箱サンプル")
        .Range("F1").Value = txt_Date.Value
        .Cells(f, strCol).Resize(UBound(v, 1), UBound(v, 2)).Value = v
    End With
    
    Call QtyTotal(myCls)
    
    Application.ScreenUpdating = True
    
    Call LineClear
    Call GetQtyInfo
    
    MsgBox "箱サンプルへの書き込みが完了しました"
    
 End Sub

 Sub QtyTotal(myCls As String)
    Dim w As Variant
    Dim f As Long
    Dim e As Long
    Dim dicW As Object
    Dim i As Long
    Dim j As Long
    Dim myCode As String
    Dim myMedia As String
    Dim myQty As Long
    Dim dKey As String
    Dim v As Variant
    
    Set dicW = CreateObject("Scripting.Dictionary")
    
    With Sheets("箱サンプル")
        w = myCls & 0
        f = dicSample(w)(0)

        e = dicSample(w)(1)
        dicW.RemoveAll
        For j = 1 To 5 Step 4
            For i = f To e
                myCode = .Cells(i, j).Value
                If Len(myCode) > 0 Then
                    myCode = Left(myCode, Len(myCode) - 1)
                    myMedia = .Cells(i, j + 1).Value
                    myQty = Val(.Cells(i, j + 2).Value)
                    dKey = myCode & vbTab & myMedia
                    If Not dicW.exists(dKey) Then dicW(dKey) = Array(myCode, myMedia, 0)
                    v = dicW(dKey)
                    v(2) = v(2) + myQty
                    dicW(dKey) = v
                End If
            Next
        Next
        With .Range(.Cells(f, "J"), .Cells(e, "L"))
            .ClearContents
            If dicW.Count > 0 Then .Resize(dicW.Count).Value = _
                WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicW.items))
        End With
    End With
    
    Set dicW = Nothing
    
 End Sub

 (ぶらっと)
----
 ありがとうございます！

 何回かテストしましたが今のところうまく動いています。

 もしエラーが出てどうしても対処法が分からない時はまたお世話になるかもしれませんが（できるだけ自力で解決する努力はします）
 本当にありがとうございました

 (peridot)
----
 ぶらっと様

 すみません、もう一つお伺いしたいのですが…

 ユーザーが「箱サンプル」シートにユーザーフォームからではなく直接手打ちで入力してしまった場合に「合計」が
 計算されないので、一旦Deleteキーでクリアしてユーザーフォームから入力しようとしました、
 すると、ユーザーフォームで「分類」→「枝番」→「記号」→「媒体名」を選択した段階で、クリアしたはずの
 数値がユーザーフォームに出てしまいます。
 そして以下の現象が起きます。

 （1）　「箱サンプル」シートに以下のように手打ち

 　　E　　　F　　　G
 1
 2 記号　媒体名　件数
 3 SK2　　KZ　　　10
 4 SK2　　MZ　　　15

 （2）DeleteキーでE3〜G4をクリア
 （3）ユーザーフォームを表示、「分類：作業簿_SK」→「枝番：2」→「記号：SK」→「媒体名：KZ」を選択
 （4）件数に「10」が表示される（「MZ」には「15」が表示される）
 （5）「KZ」を「21」に更新して（「MZ」は選択しないで）入力ぼコマンドボタンを押す
 （6）「箱サンプル」シートに下記のように転記される

 　　E　　　F　　　G
 1
 2 記号　媒体名　件数
 3 SK2　　KZ　　　21
 4 SK2　　MZ　　　15　　　←ユーザーフォームで選択していないのに入力される

 （7）次にユーザーフォームを開くと「KZ」の数値は「10」（手打ちした時の数値）で表示されます。

 データ消去をマクロの.ClearContentsで行っても同じです。
 手打ちしてしまった時の値をずっと保持し続けてしまう現象はどうすれば解消されますでしょうか。

 ★追加です・その１
 上記とは別だと思いますが、枝番が「3」以降の場合、既に入力済みのデータを選択した時
 （例えば「SK3/KZ/50」が入力されていたとしてユーザーフォームで「SK3/KZ」を選択した場合）
 枝番1や2では入力済みの「件数」がユーザーフォームに表示されますが、3以降では件数に何も表示されません

 ★追加です・その２
 今回のようにユーザーが手動でベタ打ちしてしまった場合、その時点で「合計」はされません。
 その後ユーザーフォームから何かしら入力の操作を行うとベタ打ちした分も合計されますが、
 もしベタ打ちしてしまった場合に備えて、「合計」のコードだけを別に独立させることはできますでしょうか。
 シートの上にコマンドボタンを置いて「手動合計」のようなコードで合計させようかと思いましたが、
 A列側のデータとE列側のデータの比較、既に合計されていつデータとの集約などをどうすればよいか
 ずっと考えていたのですが思いつかなくて…
  Sub QtyTotal(myCls As String)
 これを応用できないかと色々試しましたがどうしてもうまくいきません…


 (peridot)
----
 まず、簡単なところから。
 SK3　があるのにコピーされない件、箱サンプルシートからの情報取り込みが、初期段階のみで行っていたので
 これを、箱サンプルシートの更新の都度、再度取り込むことで、ここはＯＫになる。
 で、強制的に合計処理を行う件については、そちらで着目している　Sub QtyTotal(myCls As String)
 これを活用することができる。 ただ、その前に、箱サンプルシートのデータ取り込みも行う必要があるけど。
 
 で、やっかいなのが、手作業でＡ〜Ｃ，Ｅ〜Ｇを変更。ありうるよね。実務としては。 (本当は禁止したいけど）
 この時、クリア前のデータを、保持していて、そこにユーザーフォームから追加という構造なので、シート上は
 値が無いのに、クリア前に存在していたものも、更新に、そのまま使われてしまう。
 シートイベントで、ここが変更されたら自動更新ということもできないことはないけど、ロジックが
 きわめて入り組んでしまうので、悩むところ。

 いずれにしても、ちょっと時間ください。

 (ぶらっと)
----
 なるほど、情報取り込みをブックを開くタイミングで行っているので一度開いたデータを変更して
 そのまま読み込んだりできないことがあるんですね。
 入力した人から「数字が出るのと出ないのとある」と言われてテストしていたので、テストで追加したデータのみを見ていました。

 手作業の変更は、一度ユーザーフォームで入力したものを「１個だけ訂正・追加」という時によく起きます。
 入力者としては「１個だけだから」というつもりでやってしまうようです。
 この辺の徹底も頭を痛めるところです…

 (peridot)

 
----
 結局、箱サンプルシートを手作業で変更した際にも自動的に合計処理を行うよう改訂。
 なお、今後、単独で、合計処理を行うような部分を追加する場合は、以下で記述する
 シートモジュールのコードを参考にしてがんばってほしい。

 (標準モジュールのパブリック変数　追加）

  Public skipChange As Boolean       '★追加 2012/4/24

 (ユーザーフォームモジュール)

 CommandButton1_Click の　Application.ScreenUpdating = False　から　MsgBox "箱サンプルへの書き込みが完了しました"　までを

    Application.ScreenUpdating = False
    
    skipChange = True       '★追加 2012/4/24
    
    With Sheets("箱サンプル")
        .Range("F1").Value = txt_Date.Value
        .Cells(f, strCol).Resize(UBound(v, 1), UBound(v, 2)).Value = v
    End With
    
    Call QtyTotal(myCls)
    
    skipChange = False      '★追加 2012/4/24
    
    Application.ScreenUpdating = True
    
    Call LineClear
    Call getSample          '★追加 2012/4/24
    Call GetQtyInfo
    
    MsgBox "箱サンプルへの書き込みが完了しました"

 (で、箱サンプル　シートのシートモジュールに） 15:37 一部変更

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim w As Variant
    Dim f As Long
    Dim e As Long
    Dim myCls As String
    
    If skipChange Then Exit Sub
    
    skipChange = True
    
    For Each w In dicSample
        If Right(w, 1) = "0" Then
            myCls = Left(w, Len(w) - 1)
            f = dicSample(w)(0)
            e = dicSample(w)(1)
            If Not Intersect(Target, Range("A" & f & ":G" & e)) Is Nothing Then
                Call getSample
                Call GetQtyInfo
                Call QtyTotal(myCls)
                Call getSample
                Call GetQtyInfo
                MsgBox myCls & " についての箱サンプルの合計処理を自動実行しました"
            End If
        End If
    Next
    
    skipChange = False
    
 End Sub

 (ぶらっと)

----
 ぶらっと様

 ありがとうございます。

 最初に改訂コードを貼りつけて、「箱サンプル」シートに手打ち入力しようとすると、箱サンプルのシートモジュール

 For Each w In dicSample

 で「オブジェクトが必要です」のエラーが出たのですが、一旦保存してから再度試すと出なくなりました。
 前のコードの名残でしょうか。

 また、箱サンプルシートの一つのセルをクリックする・あるいは値を入力すると一つのセルごとに
 「作業簿_SKについての箱サンプルの合計処理を自動実行しました」
 のメッセージが出る（クリックしただけで、値を入力しなくても出る）のは仕様ということでよろしいでしょうか（一応、入力者に説明しようと思いますので…）

 > なお、今後、単独で、合計処理を行うような部分を追加する場合は、以下で記述する
 > シートモジュールのコードを参考にしてがんばってほしい。

 了解いたしました。ありがとうございます。
 その点で後学のためにお教えいただきたいのですが、

            f = dicSample(w)(0)
            e = dicSample(w)(1)

 これらは何を指しているのでしょうか？

 (peridot)
----
 >「オブジェクトが必要です」のエラーが出たのですが、一旦保存してから再度試すと出なくなりました。

 何度かいっているように、プロジェクトがリセットされると、モジュールレベルの変数も初期化される。
 エラーでとまった場合もそうだけど、モジュールコードを打ち直すと、これは、そのものズバリ、リセットされる。
 なので、閉じて開くか、前にも言ったように、Preparationを実行するか、いずれかで。

 >（クリックしただけで、値を入力しなくても出る）

 シート上で値を変更すると、その都度、合計処理を行いメッセージをだしているけど、クリックだけで？
 Worksheet_Change　なので、それは考えにくいんだけど？Worksheet_SelectionChange なら、ありうるけど？
 一応、こちらでもチェックしてみるね。

↑　やっぱり、クリックだけでは、処理は行われないし、当然メッセージもでないよ？？

 >f = dicSample(w)(0)

 これに限らず、コードで使っているDictionaryの概説のようなメモを、あとでアップするけど、とりあえず
 dicSample内で、キーが、分類0 になっているもののデータはLBoundが0の一次元配列で　その分類に関する
 箱サンプル上のデータ開始行とデータ終了行が格納されている。なので、その配列(0) なので 開始行。

 (ぶらっと)

 



----
 すみません、説明が足りなかったです…
 「クリックだけで」というか、ダブルクリックでセルを編集可能な状態にして、値を入力しないで…ということです。
 一度セルを編集可能にしているのでChangeイベントが発生するのは当たり前…なんですよね？

 (peridot)
----
 >ダブルクリックでセルを編集可能な状態にして、値を入力しないで

 うん。この状態は、空白値が入力されたという状況なのでね。

 以下、コードで使っているDictionary メモ

 dic  単価マスタに存在する分類、記号、媒体の組合せのリスト。最初に１回、GetPriceListで生成。
      内部的には 親dic（キーは分類）　子dic(キーは記号) 孫dic(キーは媒体）の三層構造

 dicLine 単価マスタの分類ごとの記号・媒体の組合せの行数
　　　キー　分類0 データが行数
      キー　分類n (n は 1〜）データが記号　フォーム上でラベルのキャプションセットに使用
 
 dicSample 箱サンプルシート情報
　　　キー　分類0 データは　当該分類に関する箱サンプルシート上のデータ開始行と終了行を格納した一次元配列
      キー　分類1 データは　当該分類に関するA〜C列のセルの値（二次元配列）
　　　　　　分類2 データは　当該分類に関するE〜G列のセルの値（二次元配列）

 dicQty 箱サンプルシートにセットされている数量情報。ユーザーフォームでマッチすればテキストボックスに抽出。
　　　キー　分類 tab 記号枝番 tab 媒体　データが　シート上の数量

 (ぶらっと)
----
 ぶらっと様

 詳しいご説明をありがとうございます。
 dictionaryオブジェクトはよく使われるのにあまり理解できていなかったので、解説をいただいて助かりました。
 今後の応用のために勉強します。

 ありがとうございました

 (peridot)