Excel、dictionaryを使った連想記憶を試しました。

Option Base 1
Option Explicit

Sub ディクショナリ試験()
    Dim arry As Variant
    Dim val As Variant
    Dim gyou As Long
    Dim keta As Long
    Dim i As Long
    Dim j As Long
    Dim mydic As Object
    Dim namae As Variant
    
    
    Set mydic = CreateObject("Scripting.Dictionary")
    
    With Worksheets("Sheet1")
        arry = .Range(Cells(1, 1), Cells(5, 2))
    End With
    
     gyou = UBound(arry, 1)
     keta = UBound(arry, 2)
     
    With Worksheets("Sheet1")
        For i = 1 To gyou
            If Not mydic.exists(.Cells(i, 1).Value) Then
                mydic.Add .Cells(i, 1).Value, .Cells(i, 2).Value    'ここでキーとitemを
            End If                                                  '辞書に登録する
        Next i                                                      'この辺の書き方が分かりづらい
    End With
    
繰り返し:
    namae = InputBox("品名")
    If namae = "終わり" Then
        Exit Sub
    End If
    
    Debug.Print namae                                               '品名を入力して
    Debug.Print mydic.Item(namae)                                   '品名に応じた数字が表示できる
    
    
    GoTo 繰り返し
    Set mydic = Nothing　　　　　　　　　　　’ここに到達しないんですが、Excelの場合は注意も無いですね。
    　　　　　　　　　　　　　　　　　　　　　　　　　　　'実際は無くてもあっても関係ないようです。
End Sub
取り敢えず連想記憶みたいなことは出来るようですね。但し疑問は残ります。品名とか

名前ならひとつに決めるのが難しいように思うんですね。個人名なら同姓同名もあるし

入力にスペースが有るとか無いとか。

メリットもあるようですよ。配列なら基本は最大を見込んで決める必要があると網のですが

この場合は関係なくなるようです。初めて使って見たのでもう少しやって見たいと思います。

Excel、for eachとuboundを使って見ました。

option plicit

option base 1

Sub 試験2()
    Dim a(10) As Long
    Dim j As Long
    Dim k As Variant
    
    
    For j = 1 To 10
        a(j) = j * 100
    Next
    
    'for eachを使う
    For Each k In a()
        Debug.Print k
    Next
        
    'uboundを使う
    For j = 1 To UBound(a)
        Debug.Print a(j)
    Next
    
End Sub

　for each　とuboundは同じように使えるんでしょうが、頭が固い自分は

uboundのほうがしっくり来ます。

option plicitとoption base 1をしています。

　クリックで拡大します。

Excelの場合は、aを配列として、bを配列とすると

b=a

でコピーになるんですが、一般の言語VBとかでは同じアドレスが与えられます。

Excelで遊んでました。配列とレンジ。

Option Explicit
Option Base 1
Sub 試験()
    Dim vnttmp As Variant
    Dim 実行 As Long
    Dim 実桁 As Long

    With Worksheets("Sheet1")
        vnttmp = .Range("A2", .Range("D65536").End(xlUp)).Value

    End With
    
    実行 = UBound(vnttmp, 1)
    実桁 = UBound(vnttmp, 2)
    
    vnttmp(10, 3) = "Takahashi"
    
    Worksheets("Sheet1").Range(Cells(2, 1), Cells(実行, 実桁)) = vnttmp
    
End Sub

Excelの場合は、2次元の配列を簡単に扱えるので、ワークシートから配列への読込や

その逆でも、1行で済むのが素晴らしいですね。でも色んな関数とかが書いてあれば

駄目のようですが。(^0^)

 

試験に使ったワークシートです。確かに1カ所変更になってます。

Excelリストボックスで遊んでました。続き。

Private Sub UserForm_InitializeCall()
  Dim 元表 As Range
  Dim i As Long
  'Dim dic As Object
  Dim 配列 As Variant
  Dim C配列 As Variant
 
 
 
  With Sheets("米検査日程")
    'Set 元表 = .Range("C2", .Range("IV2").End(xlToLeft)).Resize(2)
    Set 元表 = .Range("C2", .Range("IV3").End(xlToLeft))
  End With
 
  If Not (IsArray(元表)) Then
    配列 = Array(元表)
  Else
    配列 = 元表
  End If
 
  配列 = WorksheetFunction.Transpose(配列)

  C配列 = 配列
  Call 空白行削除(C配列, 配列)
 
  'Set dic = CreateObject("Scripting.Dictionary")
  With 検査日選択.ListBox1
    .ColumnCount = 2
    .ColumnWidths = "70;30"
    '.Column = 元表.Value
    .List = C配列
    
    'For i = .ListCount - 1 To 0 Step -1
    '    If Len(.List(i, 0)) = 0 Then
    '        .RemoveItem i
    '    ElseIf dic.Exists(.List(i, 0)) Then
    '        .RemoveItem i
    '    Else
    '        dic(.List(i, 0)) = Empty
    '    End If
    'Next
    
  End With
 
  Set 元表 = Nothing
  Set C元表 = Nothing
 
  'Set dic = Nothing


End Sub
Sub 空白行削除(Ctmp, tmp)
    Dim 書込行数 As Long
    Dim 実カラム As Long
    Dim 実行数 As Long
    Dim i As Long
    Dim j As Long
        
    
    実カラム = UBound(tmp, 2)
    実行数 = UBound(tmp, 1)
    書込行数 = 1
    
       
    For i = 1 To 実行数
        If tmp(i, 1) <> "" Then
            For j = 1 To 実カラム
                Ctmp(書込行数, j) = tmp(i, j)
            Next
            
            書込行数 = 書込行数 + 1
            
        End If
    Next
    
    For i = 書込行数 To 実行数
        For j = 1 To 実カラム
            Ctmp(i, j) = ""
        Next
    Next
    
End Sub

実際は動いていても、よく分からないところが有ったので、それを変えるとこうなるでしょう。

前は縦の表から、リストボックスのitemを設定しましたが、今回は横の表から作ると

どうなるかですね。

配列 = WorksheetFunction.Transpose(配列)を行えば、縦の表と同じく

出来ると言うことですね。

リストボックスは大体疑問が解決したような気がします。これで終わりですね。

Excelリストボックスで遊んでました。

Sub UserForm_InitializeCall()
    Dim dicTmp As Object
    Dim VntTmp As Variant
    Dim CpyVnttmp As Variant
    
    Dim VntV As Variant
    Dim i As Integer
    Dim j As Integer
    

    Set dicTmp = CreateObject("Scripting.Dictionary")
    With Worksheets("生産者")
        VntTmp = .Range("A2", .Range("D65536").End(xlUp)).Value

    End With
    
    'If Not IsArray(VntTmp) Then
    '    VntTmp = Array(VntTmp)
    'End If
                                      
    i = UBound(VntTmp, 1)
    j = UBound(VntTmp, 2)
    
    'VntTmp(10 + 1, 2 + 1) = "Chiba"
    
    CpyVnttmp = VntTmp               'Excelはこれでコピー出来ちゃう
    
    For Each VntV In VntTmp          'VntTmpとVntVは関係ない変数。何故こう書ける。
        On Error Resume Next         'ここでやっていることが正確には分からない。
        dicTmp.Add VntV, Empty
        On Error GoTo 0
    Next
    
    Call 空白行削除(CpyVnttmp, VntTmp) '上のi,jと数は同じ
    i = UBound(CpyVnttmp, 1)          '配列のitemにnullを代入しても
    j = UBound(CpyVnttmp, 2)          '配列は存在する

    
    With 農家選択.ListBox1
     .List = CpyVnttmp
     .ColumnWidths = "30;150;100;20"
     .ColumnCount = 4
    End With
    
    
    Set dicTmp = Nothing              'ディクショナリーを使わないと要らないでしょう。
    
    農家選択.Show

End Sub

Sub 空白行削除(Ctmp, tmp)
    Dim 書込行数 As Long
    Dim 実カラム As Long
    Dim 実行数 As Long
    Dim i As Long
    Dim j As Long
        
    
    実カラム = UBound(tmp, 2)
    実行数 = UBound(tmp, 1)
    書込行数 = 1
    
       
    For i = 1 To 実行数
        If tmp(i, 1) <> "" Then
            For j = 1 To 実カラム
                Ctmp(書込行数, j) = tmp(i, j)
            Next
            
            書込行数 = 書込行数 + 1
            
        End If
    Next
    
    For i = 書込行数 To 実行数
        For j = 1 To 実カラム
            Ctmp(i, j) = ""
        Next
    Next
    
End Sub

よく分からないままで、教えて貰ったコードを使ってましたが、この場合は配列の空白を

削除しないようです。Dictionaryを使えば、同じものコードのものが作られない、空白は

削除されると勘違いしてました。違う場面でもこのコードを使ってました。その場面とは

横に広がるワークシートです。しかも空白が多い。その場合でも旨く行ってたんですが。

疑問ですね。(^0^)

Excel2次元配列コピー

Sub UserForm_InitializeCall()
    Dim dicTmp As Object
    Dim VntTmp As Variant
    Dim CpyVnttmp As Variant
    
    Dim VntV As Variant
    Dim i As Integer
    Dim j As Integer
    

    Set dicTmp = CreateObject("Scripting.Dictionary")    'ディクショナリーを使わないと要らないでしょう。
    With Worksheets("生産者")
        VntTmp = .Range("A2", .Range("D65536").End(xlUp)).Value

    End With
    
    'If Not IsArray(VntTmp) Then　　　'ここから3行は普通は必要ないようです。
    '    VntTmp = Array(VntTmp)　　　 '上の3行でリストの元を作成してる場合必要ないようです。
    'End If
                                      'VntTmpの行数は分からないのが普通です。
    i = UBound(VntTmp, 1)             'データの行数と合う
    j = UBound(VntTmp, 2)             'データの項目数と合う
    
    VntTmp(10 + 1, 2 + 1) = "Chiba"  'データの部分だけ数えると行、カラムどちらも+1しないとずれますね。添え字は0から。
    
    CpyVnttmp = VntTmp　　　　　　　　'2次元の配列のコピーがこれで出来るんですが、何か分かりづらいですよね。
    
    For Each VntV In VntTmp          'この場合のように隙間が無いワークシートから表を作る場合は必要ないようです。
        On Error Resume Next
        dicTmp.Add VntV, Empty
        On Error GoTo 0
    Next
    
    
    
    With 農家選択.ListBox1
     .List = VntTmp
     .ColumnWidths = "30;150;100;20"
     .ColumnCount = 4
    End With
    
    
    Set dicTmp = Nothing              'ディクショナリーを使わないと要らないでしょう。
    
    農家選択.Show

End Sub
デバックで見たんですが、確かに実体が作られてました。VBとか一般の言語はアドレスだけが

コピーされるはずです。

Excelのリストボックスの使い方でいじりました。

Sub UserForm_InitializeCall()
    'Dim dicTmp As Object
    Dim VntTmp As Variant
    'Dim VntV As Variant
    Dim VntArry(2, 3) As Variant
    
    VntArry(0, 0) = 10
    VntArry(0, 1) = "厳美町○○"
    VntArry(0, 2) = "鈴木"
    VntArry(0, 3) = "39-1234"
    
    VntArry(1, 0) = 20
    VntArry(1, 1) = "厳美町△○"
    VntArry(1, 2) = "佐藤"
    VntArry(1, 3) = "39-2345"
    
    VntArry(2, 0) = 30
    VntArry(2, 1) = "厳美町○△"
    VntArry(2, 2) = "佐々木"
    VntArry(2, 3) = "39-3456"
    

    'Set dicTmp = CreateObject("Scripting.Dictionary")　　'ディクショナリーを使わないと要らないでしょう。
    'With Worksheets("生産者")
    '    VntTmp = .Range("A2", .Range("D65536").End(xlUp)).Value

    'End With
    
    'If Not IsArray(VntTmp) Then　　　'ここから3行は普通は必要ないようです。
    '    VntTmp = Array(VntTmp)　　　 '上の3行でリストの元を作成してる場合必要ないようです。
    'End If
     
    'For Each VntV In VntTmp　　　　　'この場合のように隙間が無いワークシートから表を作る場合は必要ないようです。
    '    On Error Resume Next
    '    dicTmp.Add VntV, Empty
    '    On Error GoTo 0
    'Next
    
    With 農家選択.ListBox1
     '.List = VntTmp
     .List = VntArry
     .ColumnWidths = "30;150;100;20"
     .ColumnCount = 4
    End With
    
    
    'Set dicTmp = Nothing              'ディクショナリーを使わないと要らないでしょう。
    
    農家選択.Show

End Sub
ワークシートからデータを取り込む場合は、最初の方ですね。でも2次元配列と形式が

似てるので、配列から設定することもありそうですよね。よく分からないのが今はコメントに

してますが、VntTmpが2次元配列と同等と言うことです。だったら同じように添え字で

アクセスできるんだろうか?

Excelのリストボックスの使い方でいじりました。

Option Explicit


Private Declare Function FindWindowEx Lib "User32" _
                    Alias "FindWindowExA" ( _
                    ByVal Hwnd1 As Long, _
                    ByVal Hwnd2 As Long, _
                    ByVal lpsz1 As String, _
                    ByVal lpsz2 As String) As Long

Private Declare Function GetWindowRect Lib "User32" ( _
                    ByVal Hwnd As Long, _
                    lpRect As RECT) As Long

Private Declare Function GetDC Lib "User32" ( _
                    ByVal Hwnd As Long) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" ( _
                    ByVal hDC As Long, _
                    ByVal nIndex As Long) As Long

Private Declare Function ReleaseDC Lib "User32" ( _
                    ByVal Hwnd As Long, _
                    ByVal hDC As Long) As Long

Private Const LOGPIXELSX = 88
Private Const POINTS_PER_INCH As Long = 72

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Function PointsPerPixel() As Double
    Dim hDC As Long
    Dim lDotsPerInch As Long

    hDC = GetDC(0&)
    lDotsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
    PointsPerPixel = POINTS_PER_INCH / lDotsPerInch
    ReleaseDC 0&, hDC
End Function

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

    検査データ入力.生産者CD = ListBox1.List(ListBox1.ListIndex)
    検査データ入力.氏名 = ListBox1.List(ListBox1.ListIndex, 2)
    検査データ入力.住所 = ListBox1.List(ListBox1.ListIndex, 1)
    検査データ入力.電話番号 = ListBox1.List(ListBox1.ListIndex, 3)
    農家選択.Hide
    ListBox1.ListIndex = -1
    
End Sub

Private Sub UserForm_Initialize()

    Dim HwndDesk As Long
    Dim HwndChart As Long
    Dim uChartPos As RECT

    Dim Rng As Range

    Dim バージョン As String
    
    バージョン = Application.Version

    If バージョン = "11.0" Then

        Set Rng = ActiveCell(2)

        With Rng.Parent.ChartObjects.Add(0, 0, 1, 1)
            .Top = Rng.Top
            .Left = Rng.Left
            .Activate
            .Delete
        End With

        HwndDesk = FindWindowEx _
                    (Application.Hwnd, 0&, "XLDESK", vbNullString)
        HwndChart = FindWindowEx(HwndDesk, 0&, "EXCELE", vbNullString)
        GetWindowRect HwndChart, uChartPos

        StartUpPosition = 0

        Left = uChartPos.Left * PointsPerPixel
        Top = uChartPos.Top * PointsPerPixel
    End If

    Call UserForm_InitializeCall

End Sub


Private Sub UserForm_Click()

End Sub

Sub UserForm_InitializeCall()
    'Dim dicTmp As Object
    Dim VntTmp As Variant
    'Dim VntV As Variant

    'Set dicTmp = CreateObject("Scripting.Dictionary")　　'ディクショナリーを使わないと要らないでしょう。
    With Worksheets("生産者")
        VntTmp = .Range("A2", .Range("D65536").End(xlUp)).Value

    End With
    
    'If Not IsArray(VntTmp) Then　　　'ここから3行は普通は必要ないようです。
    '    VntTmp = Array(VntTmp)　　　 '上の3行でリストの元を作成してる場合必要ないようです。
    'End If
     
    'For Each VntV In VntTmp　　　　　'この場合のように隙間が無いワークシートから表を作る場合は必要ないようです。
    '    On Error Resume Next
    '    dicTmp.Add VntV, Empty
    '    On Error GoTo 0
    'Next
    
    With 農家選択.ListBox1
     .List = VntTmp
     .ColumnWidths = "30;150;100;20"
     .ColumnCount = 4
    End With
    
    
    'Set dicTmp = Nothing              'ディクショナリーを使わないと要らないでしょう。
    
    農家選択.Show

End Sub

ワークシートからリストボックスのitemを設定するところを、少しだけいじりました。

ほぼ100％丸写しだったので、調べたことを含みで直してみました。でもやはり

隙間があるワークシートから上手く作ることが出来ないので、やはり元の通りの

コードがベターですね。

でもArrayに変更してる箇所があるんですが、これは要らないような気もします。

そもそもがArrayだと思うんです。

Ｅｘｃｅｌのリストボックス

　自分自身それ程Ｅｘｃｅｌに詳しいわけではありません。しかし、幾らかでも役に立ちそうなことをしようと

すると、リストボックスに突き当たるように思います。ソフトというのは大概入力があって出力があります。

入力をするときに、記憶から入力するというのは、自分の場合は絶対出来ません。覚えられないし

間違います。例えば人を入力する場合は、コードを付けておいた方が何かと便利です。しかし、誰が

何番であるかは、覚えることが出来ないのが普通ですよね。一部は覚えておいたにしても、全部は無理。

　ユーザーフォームを使うことになるんですが、入力用の全体のフォームと例えば個人を選択するフォーム

とワークシートがあるとします。例えばの話しですので、ワークシートは今回はいじりません。入力の全体の

フォームと個人を選択するサブのフォーム。この場合はVBAを考えてますよ。

   以下の画像はクリックで拡大します。

全く教えて貰わないのは、このワークシートだけです。(^0^)

　

ユーザーフォームとワークシートの関係。

　

入力はかんな感じですかね。一部ですが。

この辺は教えた貰ったと言うよりも丸写しです。アクティブセルを感知して

その辺へユーザーフォームを開くのに必要です。無くても買わないかなあ。

　

選択した項目を入力のユーザーフォームへ送るのに必要な部分。

　

多分ここが肝なんでしょうが、要はデータ件数を基本は分からない。ワークシートから

リストボックスのitemを設定します。この辺も教えられたので、大体の事しか分かりません。

でも結構便利な部分です。Dictionaryを使ってます。