コンボボックスの代替案(デザインの観点から)

投稿者 : くうふく     投稿日時 : 2024/02/17(Sat) 18:32:15     OS : Windows 10     EXCEL : Office 365

---

請求書を作るにあたり、取引先を一覧から選択して入力できるようにしたです
コンボボックスでは90年代のようのUIになってしまうので、代替案を考えています

例えば選択用に取引先一覧とスライサーを用意しておき、
スライサーの取引先名をくりっくしたら
シート1の取引先を入力するシートに入力するようなことはできないでしょうか？

投稿者 : higeru     投稿日時 : 2024/02/18(Sun) 07:59:39

---

　90年代のUIの具体的なイメージは分かりませんが、ActiveXコントロールを自作すればよいのではないですかね。
　ただしそれはVBAの範疇ではないし、私にはそのスキルはないのでアドバイスはできませんが。

投稿者 : tek     投稿日時 : 2024/02/18(Sun) 09:18:11

---

https://learn.microsoft.com/ja-jp/office/vba/api/excel.worksheet.pivottablechangesync
https://learn.microsoft.com/ja-jp/office/vba/api/excel.pivottable.databodyrange
が使えると思います。

投稿者 : tek     投稿日時 : 2024/02/19(Mon) 09:31:28

---

デザインとしては？ですが、データをスクロール外に配置し、スライサーのみを表示させるとして、
https://learn.microsoft.com/ja-jp/office/vba/api/excel.worksheet.calculate(even)
を使い勉強してみました。
新しいシートのシートモジュールにコピペし、一度　design_sheet　を実施
使い物になるのかなあ？

ところで、データの入力規則ではだめですか？
https://www.yrl.com/column/wazaari_pc/select-data_multiple-candidates_excel.html
「設定」タブで「入力値の種類」から「リスト」を選択
「元の値」で取引先一覧の範囲を選択

Sub design_sheet()
    Dim d(1 To 2)
    Dim i As Long
    Dim tbl As ListObject
    
    If Me.ListObjects.Count Then Exit Sub
    Application.EnableEvents = False
    d(1) = Split("取引先 A社 B社 C社 D社")
    d(2) = Split("月 1月 2月 3月 4月 5月 6月")
    For i = 1 To UBound(d)
        With Me.Cells(i * 40 + 2, 1).Resize(UBound(d(i)) + 1)
            .Value = WorksheetFunction.Transpose(d(i))
            Me.ListObjects.Add xlSrcRange, .Cells, , xlYes
        End With
        With Me.Cells(i * 40, 1)
            Set tbl = .Offset(2).ListObject
            .Formula = "=SUBTOTAL(103," & tbl.Name & "[" & tbl.ListColumns(1).Name & "])"
        End With
    Next
    make_slicer
    design2
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_Calculate()
    Dim rng As Range
    Dim tbl As ListObject
    Dim i As Long
    
    Application.EnableEvents = False
    For i = 1 To Me.ListObjects.Count
        Set rng = Me.Cells(40 * i, 1)
        If rng.Value = 1 Then
            Set tbl = rng.DirectPrecedents.ListObject
            
            '********         実際の作業に要変更  ***************************
            Debug.Print tbl.HeaderRowRange.Value, _
                tbl.DataBodyRange.SpecialCells(xlCellTypeVisible).Value
            '****************************************************************
'            tbl.Range.AutoFilter 1
'            Exit For
        End If
    Next
    Application.EnableEvents = True
End Sub

Private Sub make_slicer()
    Dim i As Long
    For i = 1 To Me.ListObjects.Count
        ThisWorkbook.SlicerCaches.Add2(Me.ListObjects(i), Me.ListObjects(i).ListColumns(1).Name). _
        Slicers.Add(Me, , , , Me.Cells(3, 1).Top, Me.Cells(i * 3 - 1).Left).Style = "SlicerStyleDark6"
    Next
End Sub

Private Sub design2()
    If Not Application.CommandBars.GetPressedMso("MinimizeRibbon") Then _
        Application.CommandBars.ExecuteMso "MinimizeRibbon"
    ActiveWindow.DisplayHeadings = False
    ActiveWindow.DisplayGridlines = False
    Application.DisplayFormulaBar = False
    Application.Goto Me.Range("A1")
    With ThisWorkbook.Windows(1).VisibleRange
        Me.ScrollArea = .Address
        .Interior.Color = &HD0D0D0
    End With
End Sub

Private Sub Worksheet_Deactivate()
    Application.EnableEvents = False
    If Application.CommandBars.GetPressedMso("MinimizeRibbon") Then _
        Application.CommandBars.ExecuteMso "MinimizeRibbon"
    Application.DisplayFormulaBar = True
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_Activate()
    Dim tbl As ListObject
    Application.EnableEvents = False
    For Each tbl In Me.ListObjects
        tbl.Range.AutoFilter 1
    Next
    If Not Application.CommandBars.GetPressedMso("MinimizeRibbon") Then _
        Application.CommandBars.ExecuteMso "MinimizeRibbon"
    Application.DisplayFormulaBar = False
    Application.EnableEvents = True
End Sub