[[20160819111616]]　『フォームのリストボックスで抽出したい。』（pony）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『フォームのリストボックスで抽出したい。』（pony）

フォームのリストボックスで抽出したい。

”価格表”ｼｰﾄ 商品価格リストがあります。
”見積作成”ｼｰﾄ　入力フォームです。

”見積作成”ｼｰﾄのB列Wクリックでフォームが開きます。

Listbox1には”価格表”ｼｰﾄ　Ｂ列の分類２
Listbox2には”価格表”ｼｰﾄ　Ｃ列の分類３
Listbox3には”価格表”ｼｰﾄ　Ｄ列の品名＆Ｇ列の金額　※２列表示したい

を、絞り込み表示できるようにしたいのですが
同じ分類名も全て表示されてしまいます。
フィルタの様に絞り込み表示する方法を
ご教授宜しくお願い致します。

Sub SetListBox(ss As String)

    Dim r As Range, c As Range, n As Integer
    ListBox1.Clear
    Set r = Sheet7.Range("A2:A1500")
    For Each c In r
        For n = 1 To 5
            If c.Text Like Mid(ss, n, 1) & "*" Then
                ListBox1.AddItem c.Offset(, 1).Value
            End If
        Next
    Next
End Sub

Private Sub CommandButton1_Click()

    SetListBox "部品1"
End Sub

Private Sub CommandButton2_Click()

    SetListBox "部品2"
End Sub

Private Sub ListBox1_Change()
Dim c As Range

    Dim br As String
    ListBox2.Clear
    ListBox3.Clear
    br = ListBox1.Value
    With Sheets("価格表")
        For Each c In .Range("B1", .Range("C" & Rows.Count).End(xlUp))
            If c.Value = br Then ListBox2.AddItem c.Offset(, 1).Value
        Next
  End With
End Sub

Private Sub ListBox2_Change()
Dim c As Range

    Dim br As String
    br = ListBox2.Value
    With Sheets("価格表")
        For Each c In .Range("C1", .Range("D" & Rows.Count).End(xlUp))
            If c.Value = br Then ListBox3.AddItem c.Offset(, 1).Value '& c.Offset(, 4).Value
            '.ColumnWidths = "140;100"
        Next
  End With
  With ListBox3
.ColumnCount = 2
.ColumnWidths = "80;60"
'.RowSource = "Sheet1!A1:D" & Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
End With

End Sub

Private Sub ListBox3_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

    Dim wSheetName As Variant
    wSheetName = ActiveSheet.Name

    With Worksheets(wSheetName)
       ' .Cells(ActiveCell.Row, ActiveCell.Column).Value = ListBox1.List(ListBox1.ListIndex, 0)
        Cells(ActiveCell.Row, 2).Value = ListBox2.Text
        Cells(ActiveCell.Row, 3).Value = ListBox3.Text
    End With
    Unload Me

End Sub

＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞

---

こんにちは

SetListBoxが何をしようとしているのか分からないのですが、「部品1」「部品2」で

始まるデータで絞り込むなら、

Sub SetListBox(ss As String)

    Dim r As Range, c As Range, n As Integer
    ListBox1.Clear
    Set r = Sheet1.Range("A2:A1500")
    For Each c In r
        If c.Text Like ss & "*" Then
            ListBox1.AddItem c.Offset(, 1).Value
        End If
    Next
End Sub

Private Sub CommandButton1_Click()

    SetListBox "部品1"
End Sub

Private Sub CommandButton2_Click()

    SetListBox "部品2"
End Sub

Private Sub ListBox1_Change()

    Dim c As Range
    Dim br As String
    If ListBox1.ListCount = 0 Then Exit Sub
    ListBox2.Clear
    ListBox3.Clear
    br = ListBox1.Value
    With Sheets("価格表")
        For Each c In .Range("B1", .Range("B" & Rows.Count).End(xlUp))
            If c.Value = br Then ListBox2.AddItem c.Offset(, 1).Value
        Next
    End With
End Sub

'ListBox3に複数列表示するなら、

Private Sub ListBox2_Change()

    Dim c As Range
    Dim br As String
    If ListBox1.ListCount = 0 Then Exit Sub
    If ListBox2.ListCount = 0 Then Exit Sub
    br = ListBox2.Value
    With Sheets("価格表")
        For Each c In .Range("C1", .Range("C" & Rows.Count).End(xlUp))
            If c.Value = br Then
                With ListBox3
                    .AddItem ""
                    .List(.ListCount - 1, 0) = c.Offset(, 1).Value
                    .List(.ListCount - 1, 1) = c.Offset(, 4).Value
                End With
            '.ColumnWidths = "140;100"
            End If
        Next
    End With
    With ListBox3
        .ColumnCount = 2
        .ColumnWidths = "80;60"
        '.RowSource = "Sheet1!A1:D" & Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    End With
End Sub

Private Sub ListBox3_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

    Dim wSheetName As Variant
    wSheetName = ActiveSheet.Name
    With Worksheets(wSheetName)
       ' .Cells(ActiveCell.Row, ActiveCell.Column).Value = ListBox1.List(ListBox1.ListIndex, 0)
        Cells(ActiveCell.Row, 2).Value = ListBox2.Text
        Cells(ActiveCell.Row, 3).Value = ListBox3.Text
    End With
    Unload Me
End Sub

Private Sub CommandButton1_Click()

    SetListBox "部品1"
End Sub

Private Sub CommandButton2_Click()

    SetListBox "部品2"
End Sub

Private Sub ListBox1_Change()

    Dim c As Range
    Dim br As String
    If ListBox1.ListCount = 0 Then Exit Sub
    ListBox2.Clear
    ListBox3.Clear
    br = ListBox1.Value
    With Sheets("価格表")
        For Each c In .Range("B1", .Range("B" & Rows.Count).End(xlUp))
            If c.Value = br Then ListBox2.AddItem c.Offset(, 1).Value
        Next
    End With
End Sub

Private Sub ListBox2_Change()

    Dim c As Range
    Dim br As String
    If ListBox1.ListCount = 0 Then Exit Sub
    If ListBox2.ListCount = 0 Then Exit Sub
    br = ListBox2.Value
    With Sheets("価格表")
        For Each c In .Range("C1", .Range("C" & Rows.Count).End(xlUp))
            If c.Value = br Then
                With ListBox3
                    .AddItem ""
                    .List(.ListCount - 1, 0) = c.Offset(, 1).Value
                    .List(.ListCount - 1, 1) = c.Offset(, 4).Value
                End With
            '.ColumnWidths = "140;100"
            End If
        Next
    End With
    With ListBox3
        .ColumnCount = 2
        .ColumnWidths = "80;60"
        '.RowSource = "Sheet1!A1:D" & Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    End With
End Sub

Private Sub ListBox3_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

    Dim wSheetName As Variant
    wSheetName = ActiveSheet.Name
    With Worksheets(wSheetName)
       ' .Cells(ActiveCell.Row, ActiveCell.Column).Value = ListBox1.List(ListBox1.ListIndex, 0)
        Cells(ActiveCell.Row, 2).Value = ListBox2.Text
        Cells(ActiveCell.Row, 3).Value = ListBox3.Text
    End With
    Unload Me
End Sub

詳細が分からないので、全体的な動作確認はしていなのです。そちらで適宜修正して下さい。

（ウッシ） 2016/08/19(金) 13:38

---

ウッシ様
複数列表示ができました。
ありがとうございました。

再度質問させて頂きたいのですが

Listbox 1.2.3に絞り込み表示する際
フィルタをかけた時の様に、同じ文言は１行のみの表示にしたいです。

宜しくお願い致します。

（pony） 2016/08/19(金) 15:12

---

こんにちは

Sub SetListBox(ss As String)

    Dim r As Range, c As Range, n As Integer
    ListBox1.Clear
    Set r = Sheet1.Range("A2:A1500")
    With CreateObject("Scripting.Dictionary")
        For Each c In r
            If c.Text Like ss & "*" Then
                .Item(c.Text) = Empty
            End If
        Next
        ListBox1.List = .Keys
    End With
End Sub

Private Sub CommandButton1_Click()

    SetListBox "部品1"
End Sub

Private Sub CommandButton2_Click()

    SetListBox "部品2"
End Sub

Private Sub ListBox1_Change()

    Dim c  As Range
    Dim br As String
    If ListBox1.ListCount = 0 Then Exit Sub
    Dim d  As Object
    ListBox2.Clear
    ListBox3.Clear
    br = ListBox1.Value
    Set d = CreateObject("Scripting.Dictionary")
    With Sheets("価格表")
        For Each c In .Range("B1", .Range("B" & Rows.Count).End(xlUp))
            If c.Value = br Then
                d.Item(c.Offset(, 1).Value) = Empty
            End If
        Next
        ListBox2.List = d.Keys
    End With
    Set d = Nothing
End Sub

Private Sub ListBox2_Change()

    Dim c As Range
    Dim br As String
    If ListBox1.ListCount = 0 Then Exit Sub
    If ListBox2.ListCount = 0 Then Exit Sub
    br = ListBox2.Value
    With Sheets("価格表")
        For Each c In .Range("C1", .Range("C" & Rows.Count).End(xlUp))
            If c.Value = br Then
                With ListBox3
                    .AddItem ""
                    .List(.ListCount - 1, 0) = c.Offset(, 1).Value
                    .List(.ListCount - 1, 1) = c.Offset(, 4).Value
                End With
            '.ColumnWidths = "140;100"
            End If
        Next
    End With
    With ListBox3
        .ColumnCount = 2
        .ColumnWidths = "80;60"
        '.RowSource = "Sheet1!A1:D" & Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    End With
End Sub

Private Sub ListBox3_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

    Dim wSheetName As Variant
    wSheetName = ActiveSheet.Name
    With Worksheets(wSheetName)
       ' .Cells(ActiveCell.Row, ActiveCell.Column).Value = ListBox1.List(ListBox1.ListIndex, 0)
        Cells(ActiveCell.Row, 2).Value = ListBox2.Text
        Cells(ActiveCell.Row, 3).Value = ListBox3.Text
    End With
    Unload Me
End Sub

Listbox3 はＤ列の品名だけで集約するのですか？
Ｇ列の金額はＤ列の品名毎に合計ですか？

（ウッシ） 2016/08/19(金) 15:51

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.