Board logo

標題: VBA 抓取ListBox中的內容 [打印本頁]

作者: wang077    時間: 2021-6-28 16:25     標題: VBA 抓取ListBox中的內容

在ListBox中我已經新增好幾筆item
現在我要把ListBox內的資料當做篩選條件,而且一次篩選多筆
請問我該怎麼寫?
[attach]33469[/attach]
[attach]33470[/attach]
作者: samwang    時間: 2021-6-28 17:34

回復 1# wang077 [/b   

方便提供附件嗎? 謝謝
作者: wang077    時間: 2021-6-28 21:57

回復 2# samwang
[attach]33471[/attach]
類似這樣
作者: wang077    時間: 2021-6-29 09:46

回復 2# samwang
[attach]33473[/attach]
[attach]33472[/attach]
大神,我後來改用CheckBox然後放進迴圈。
但要怎麼篩選多筆CheckBox?
作者: wang077    時間: 2021-6-29 14:48

回復 2# samwang
大神有解嗎?
作者: samwang    時間: 2021-6-29 15:02

回復 5# wang077


不好意思,沒有解法,看看其他大大是否有解法,謝謝
作者: samwang    時間: 2021-6-29 15:45

回復 5# wang077


另外請教一下,不太了解為何不直接excel 篩選就好?
作者: wang077    時間: 2021-6-29 16:14

回復 7# samwang
主管要求,而且不只這個欄位要多筆篩選,大概有10欄左右吧:L
作者: samwang    時間: 2021-6-29 16:43

本帖最後由 samwang 於 2021-6-29 16:46 編輯

回復 8# wang077


不太了解實際需求,理論上在Excel依據條件篩選後,就可以轉出結果篩選後的資料,不一定要在ListBOX清單運作
應該有其他方法可以達到需求,但還是需要你有提供實際的範本需求, 才可以討論可行性,謝謝。
作者: wang077    時間: 2021-7-1 09:43

本帖最後由 wang077 於 2021-7-1 09:44 編輯

回復 9# samwang
[attach]33477[/attach]
像是這樣,我目前創了2個機台,如果我有好幾個機台
就可以直接用ListBox快速去多條件篩選,
而不用去每個機台的Sheet裡篩選查詢
但現在的問題就是ListBox我只能做到一個篩選
而複選ListBox來篩選我不知道怎麼解
作者: samwang    時間: 2021-7-1 12:30

本帖最後由 samwang 於 2021-7-1 12:32 編輯

回復 10# wang077

因為表單寫法我懂一點點而已,可以不用listBox呈現嗎?
也就是說在Excel輸入你想要的查詢什麼,然後將結果在excel上面,這樣可行嗎?
作者: wang077    時間: 2021-7-1 13:11

回復 11# samwang
可以,但重點就是可以多條件篩選
作者: samwang    時間: 2021-7-1 13:40

回復 12# wang077


那是否可以請你附檔一個需求的範例,謝謝
作者: wang077    時間: 2021-7-1 13:59

回復 13# samwang
[attach]33478[/attach]
能用這個當範例嗎
公司資料,不方便放上來
作者: samwang    時間: 2021-7-1 14:22

回復 14# wang077


這個附件和你上次的附件一樣沒有範例結果,
請再確認,謝謝
作者: wang077    時間: 2021-7-1 14:49

回復 15# samwang
[attach]33479[/attach]
這樣呢?
作者: samwang    時間: 2021-7-1 15:44

回復 16# wang077

請問一下,您篩選後的數據不就等於結果嗎? 為何還要多此一舉將資料轉移到結果sheet裡面?

再次確認您的需求,個人篩選後按"執行按鈕"將那些資料到複製"結果"的sheet 嗎?
作者: wang077    時間: 2021-7-1 15:51

回復 17# samwang
因為我不只兩個機台,如果很多機台的話我就需要到每個sheet篩選
所以才需要指定機台,然後將篩選結果貼到(結果)的sheet
作者: samwang    時間: 2021-7-1 16:05

回復 18# wang077


或者我有個想法,就是將所有的活頁簿的資料彙整到總表活頁簿,
總表會有一列備註哪個機台(取各頁的活頁簿名稱),
然後篩選後按鈕將資料轉到結果,
不知道這樣可行嗎?或者你有無其他想法?
作者: wang077    時間: 2021-7-1 16:16

回復 19# samwang
好像也可以,麻煩大大了
作者: samwang    時間: 2021-7-1 19:29

回復 20# wang077


請測試看看,謝謝
作者: wang077    時間: 2021-7-2 07:51

回復 21# samwang
大大,我的權限不夠,沒辦法载下來,可以傳到我的mail嗎?
mail:a0975215828@gmail.com
作者: samwang    時間: 2021-7-2 10:20

回復 22# wang077


已寄出,請確認,謝謝
作者: wang077    時間: 2021-7-2 11:05

回復 23# samwang
收到了,感謝幫忙。
作者: wang077    時間: 2021-7-2 16:07

回復 9# samwang
大大不好意思,小弟有另一個問題
[attach]33493[/attach]
如何把機1與機2兩個excel的sheet1資料用VBA彙整到新的excel裡的sheet1
已附上範例
作者: samwang    時間: 2021-7-2 17:16

回復 25# wang077

請測試看看,可複選檔案,謝謝。

Sub 選擇檔案()
Dim Arr, WB, fc%, x%, fn$, n%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False

With Sheets("總表")
    If .FilterMode Then .ShowAllData
    .Range("a2:j" & .[a65536].End(3).Row) = ""
    With Application.FileDialog(msoFileDialogOpen)
        .InitialFileName = "D:\"
        .AllowMultiSelect = True
        .Show
        fc = .SelectedItems.Count
        If fc = 0 Then Exit Sub
        Tm = Timer
        For x = 1 To fc
            FPath = .SelectedItems(x)
            Set WB = Workbooks.Open(FPath)
            With Sheets(1)
                If .FilterMode Then .ShowAllData
                Arr = .Range("a3:i" & .[a65536].End(3).Row)
                fn = Split(ActiveWorkbook.Name, ".")(0)
            End With
            WB.Close
        n = [a65536].End(xlUp).Row + 1
        Range("a" & n).Resize(UBound(Arr), UBound(Arr, 2)) = Arr
        Range("j" & n & ":j" & [a65536].End(xlUp).Row) = fn
        Next
    End With
End With

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
MsgBox "執行完成" & Timer - Tm & " 秒"
End Sub
作者: wang077    時間: 2021-7-5 08:00

回復 26# samwang
測試過了,沒問題,非常感謝大大
大大可以稍微解釋一下這些程式碼嗎
小弟能力較差,需要理解
作者: samwang    時間: 2021-7-5 08:19

回復 27# wang077

我也是新手學習中,寫得不好請見諒,謝謝。

Sub 選擇檔案()
Dim Arr, WB, fc%, x%, fn$, n%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False

With Sheets("總表")
    If .FilterMode Then .ShowAllData                '有篩選時解除篩選
    .Range("a2:j" & .[a65536].End(3).Row) = ""      '清除資料
    With Application.FileDialog(msoFileDialogOpen)  '選擇需求檔案
        .InitialFileName = "D:\"                    '預設D槽
        .AllowMultiSelect = True                    '可複選
        .Show                                       '畫面顯示
        fc = .SelectedItems.Count                   '計算選擇檔案數
        If fc = 0 Then Exit Sub                     '沒選檔案則離開
        Tm = Timer                                  '開始計時
        For x = 1 To fc
            FPath = .SelectedItems(x)               '檔案路徑
            Set WB = Workbooks.Open(FPath)          '開啟檔案
            With Sheets(1)                          '檔案的第1 sheet
                If .FilterMode Then .ShowAllData    '有篩選時解除篩選
                Arr = .Range("a3:i" & .[a65536].End(3).Row)         '來源裝入數組
                fn = Split(ActiveWorkbook.Name, ".")(0)             '取得檔名
            End With
            WB.Close                                                '關閉來源檔案
        n = [a65536].End(xlUp).Row + 1                              '總表a欄最後一筆資料+1的位置
        Range("a" & n).Resize(UBound(Arr), UBound(Arr, 2)) = Arr    '來源貼入總表
        Range("j" & n & ":j" & [a65536].End(xlUp).Row) = fn         '來源的檔名貼入總表
        Next
    End With
End With

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
MsgBox "執行完成" & Timer - Tm & " 秒"
End Sub
作者: wang077    時間: 2021-7-5 09:16

回復 26# samwang
[attach]33506[/attach]
大大,你可以幫我看一下嗎
彙整過去的資料有些格式會跑掉
然後,有辦法連函數一起會整過去嗎
作者: samwang    時間: 2021-7-5 10:22

本帖最後由 samwang 於 2021-7-5 10:23 編輯

回復 29# wang077

請再試看看,謝謝

Sub test2()
Dim Arr, WB, fc%, x%, fn$, n%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
fileorg = ActiveWorkbook.Name
n = 1

With Sheets("總表")
    If .FilterMode Then .ShowAllData
    .Range("a1:AA" & .[a65536].End(3).Row).Delete
    With Application.FileDialog(msoFileDialogOpen)
        .InitialFileName = "D:\"
        .AllowMultiSelect = True
        .Show
        fc = .SelectedItems.Count
        If fc = 0 Then Exit Sub
        Tm = Timer
        For x = 1 To fc
            FPath = .SelectedItems(x)
            Set WB = Workbooks.Open(FPath)
            With Sheets(1)
                If .FilterMode Then .ShowAllData
                fn = Split(ActiveWorkbook.Name, ".")(0)
                .Range("a1:z" & .[a65536].End(3).Row).Copy Workbooks(fileorg).Sheets("總表").Range("a" & n)
            End With
            WB.Close
            Range("AA" & n & ":AA" & [a65536].End(xlUp).Row) = fn
            n = [a65536].End(xlUp).Row + 1

        Next
    End With
End With

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
MsgBox "執行完成" & Timer - Tm & " 秒"
End Sub
作者: wang077    時間: 2021-7-5 10:26

回復 28# samwang
[attach]33508[/attach]
大大抱歉,我現在如果要修改成
在表單的TextBox中輸入機1
就會把機1的資料copy過來
如果都沒有輸入,就把資料夾裏的檔案資料都copy過來
作者: wang077    時間: 2021-7-5 13:14

回復 30# samwang
測試過了,沒問題
31#的問題有解嗎?
作者: wang077    時間: 2021-7-5 16:25

回復 32# wang077
大神有解嗎?
我想破頭,怎麼試,都解不出來
作者: samwang    時間: 2021-7-6 07:47

本帖最後由 samwang 於 2021-7-6 07:49 編輯

回復 31# wang077 [/

將需要複製的檔案放在某個資料夾
開啟表單後選取那個資料夾
會自動顯示出那個資料裡的檔案名稱
選取檔名然後複製
請測試看看
謝謝
作者: wang077    時間: 2021-7-6 08:20

回復 34# samwang
大大,再麻煩你寄到我的mail了
作者: samwang    時間: 2021-7-6 08:41

回復 35# wang077


已寄給您了,謝謝
作者: wang077    時間: 2021-7-6 09:13

回復 36# samwang
測試過了,沒問題
非常感謝大大,一直麻煩你,辛苦了
作者: s3526369    時間: 2021-7-6 17:01

[attach]33521[/attach]
你是想像這樣單獨選取你要的內容嗎?
  1. With ListBox1
  2.           .ListStyle = 1  '序前方框框
  3. End With
複製代碼
前方加入小框框 就可以單獨選取
作者: wang077    時間: 2021-7-6 17:08

回復 36# samwang
大大,抱歉,我又有麻煩了
如果開啟表單後要直接把機1,機2叫出來在ListBox上呢,等於不要有選擇資料夾這步驟
作者: samwang    時間: 2021-7-6 17:39

回復 39# wang077


如果開啟表單後要直接把機1,機2叫出來在ListBox上呢,等於不要有選擇資料夾這步驟
>>  因為要選取資料夾才能得知有哪些檔案,不然無法知道有那些檔名,如機1,機2、機3...等等
作者: wang077    時間: 2021-7-6 19:24

回復 40# samwang
那如果直接把機1、機2那個資料夾當預設的資料夾呢?
作者: samwang    時間: 2021-7-6 20:14

本帖最後由 samwang 於 2021-7-6 20:20 編輯

回復 41# wang077

還是有問題,因為無法得知機1機2的路徑,所以無法開啟檔案,除非是固定路徑或與程式檔案放同一個路徑,
另外您10樓說有好多個機台,那為什麼現在只有預設機1機2?是另外需求嗎?
作者: wang077    時間: 2021-7-7 07:56

回復 42# samwang
因為機1,機2是我抓出來當範例用,之後如果完成還會加入更多
那如果資料夾的路徑是固定的,檔案也都固定放在資料夾裏的話呢?
作者: samwang    時間: 2021-7-7 08:29

回復 43# wang077

提供2種方法,請測試看看,謝謝

Private Sub UserForm_Activate()
Dim fs, f, fc, xD, a
Set fs = CreateObject("Scripting.FileSystemObject")
Set xD = CreateObject("Scripting.Dictionary")
'a = ThisWorkbook.Path  '程式檔與資料檔放同一個資料夾
a = "D:\test"                       '資料檔放在固定路徑
fnorg = ActiveWorkbook.Name
Set f = fs.GetFolder(a)
Set fc = f.Files
For Each f1 In fc
    n = n + 1
    If InStr(f1.Path, fnorg) Then GoTo 99
    Arr(n, 1) = f1.Path
    Arr(n, 2) = Split(f1.Name, ".")(0)
    xD(Arr(n, 2) & "") = ""
99: Next
Me.ListBox1.List = xD.keys
Set fs = Nothing: Set f = Nothing: Set fc = Nothing: Set xD = Nothing
EndSub:
End Sub
作者: wang077    時間: 2021-7-7 09:03

回復 44# samwang
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
fileorg = ActiveWorkbook.Name
Set xD = CreateObject("Scripting.Dictionary")
For i1 = 1 To n1
    If Not xD.Exists(Ar(i1, 1) & "") Then
        xD(Ar(i1, 1) & "") = ""
        For i = 1 To n
            If Arr(i, 2) = Ar(i1, 1) Then n2 = n2 + 1: Ar1(n2, 1) = Arr(i, 1)
        Next
    End If
Next
R = 1: Sheets("6月份數據").Select
With Sheets("6月份數據")
    If .FilterMode Then .ShowAllData
    .Range("a1:AA" & .[a65536].End(3).Row).Delete
    Tm = Timer
    For i1 = 1 To n2
        Set WB = Workbooks.Open(Ar1(i1, 1))
        With Sheets("6月份數據")
            If .FilterMode Then .ShowAllData
            fn = Split(ActiveWorkbook.Name, ".")(0)
            .Range("a1:z" & .[a65536].End(3).Row).Copy Workbooks(fileorg).Sheets("6月份數據").Range("a" & R)
        End With
        WB.Close
        .Range("U" & R & ":U" & .[a65536].End(xlUp).Row) = fn
        R = .[a65536].End(xlUp).Row + 1
    Next
End With
MsgBox "資料複製完成" & Timer - Tm & "秒"
Erase Arr: Erase Ar
Unload Me

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True

複製資料的時候
Set WB = Workbooks.Open(Ar1(i1, 1))
這行出現了錯誤
[attach]33522[/attach]
作者: wang077    時間: 2021-7-7 09:10

回復 45# wang077
找到錯誤了,剛剛把程式檔放再同一個資料夾,所以出現錯誤
以解決這錯誤
作者: s3526369    時間: 2021-7-7 10:12

回復 1# wang077
[attach]33523[/attach]
  1. With ListBox1
  2.           .ListStyle = 1  '序前方框框
  3. End With
複製代碼

作者: wang077    時間: 2021-7-7 10:39

本帖最後由 wang077 於 2021-7-7 10:40 編輯

回復 44# samwang
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
fileorg = ActiveWorkbook.Name
Set xD = CreateObject("Scripting.Dictionary")
For i1 = 1 To n1
    If Not xD.Exists(Ar(i1, 1) & "") Then
        xD(Ar(i1, 1) & "") = ""
        For i = 1 To n
            If Arr(i, 2) = Ar(i1, 1) Then n2 = n2 + 1: Ar1(n2, 1) = Arr(i, 1)
        Next
    End If
Next
R = 1: Sheets("6月份數據").Select
With Sheets("6月份數據")
    If .FilterMode Then .ShowAllData
    .Range("a1:AA" & .[a65536].End(3).Row).Delete
    Tm = Timer
    For i1 = 1 To n2
        Set WB = Workbooks.Open(Ar1(i1, 1))
        With Sheets("6月份數據")
            If .FilterMode Then .ShowAllData
            fn = Split(ActiveWorkbook.Name, ".")(0)
            .Range("a1:z" & .[a65536].End(3).Row).Copy Workbooks(fileorg).Sheets("6月份數據").Range("a" & R)
        End With
        WB.Close
        .Range("U" & R & ":U" & .[a65536].End(xlUp).Row) = fn
        R = .[a65536].End(xlUp).Row + 1
    Next
End With
MsgBox "資料複製完成" & Timer - Tm & "秒"
Erase Arr: Erase Ar

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
End Sub

   


大大,我把複製資料的程式碼丟進去ListBox1_DblClick裡面
可以直接選取ListBox來叫出資料,但我如果第一次點擊機1可以叫出機1的資料,我第二次點擊機2的時候
他又顯示這錯誤了
求解!
[attach]33525[/attach]
作者: wang077    時間: 2021-7-7 11:04

回復 47# s3526369
此問題已解決
感謝分享
作者: samwang    時間: 2021-7-7 13:43

回復 48# wang077


我測試沒問題,可附件讓我測試看看嗎? 謝謝
作者: wang077    時間: 2021-7-7 14:22

回復 50# samwang
[attach]33526[/attach]
[attach]33527[/attach]
麻煩大大了
作者: samwang    時間: 2021-7-7 16:11

回復 51# wang077


您提供的程式有問題,程式本來Listbox 設定為change,現在你又同時設定為Listbox_DblClick
這樣不行會衝突,而且DblClick只能單選,好像有和之前的需求又不一樣,謝謝。

原程式架構: listbox 設為複選,選擇機號,機號暫存Ar數組-->用commandbutton 執行迴圈Ar去做複製動作
作者: wang077    時間: 2021-7-7 16:28

回復 52# samwang
我後來直接在dbl_Click
下了Unload
再下show
把form重新show一次
就可以了
可以一次多選,選完2個機台後在listbox裡的空白處點兩下就好了
作者: samwang    時間: 2021-7-7 16:39

回復 53# wang077


可以提供檔案,讓我學習一下嗎? 謝謝
作者: wang077    時間: 2021-7-8 07:55

回復 54# samwang
[attach]33531[/attach]
感覺會有更好的辦法,只是目前我只做到這樣而已
作者: wang077    時間: 2021-7-8 11:04

回復 54# samwang
大大,不好意思又來麻煩你了
我現在做了一個listbox來裝篩選條件,但是只能抓到一個來篩選
有辦法抓多個條件來篩選嗎
  1. Private Sub CommandButton5_Click()
  2. For i = 0 To ListBox2.ListCount - 1
  3.         If ListBox2.Selected(i) = True Then
  4. Worksheets("總表").Range("$A$2:$T$2414").AutoFilter field:=7, Criteria1:="=" & ListBox2.List(i)
  5. End If
  6. Next
  7. End Sub
複製代碼
[attach]33533[/attach]
作者: samwang    時間: 2021-7-8 13:31

回復 56# wang077

我現在做了一個listbox來裝篩選條件,但是只能抓到一個來篩選
有辦法抓多個條件來篩選嗎


不好意思,可以解釋清楚一點嗎? listbox裝篩選後的結果嗎?
但只能抓一個來篩選??
作者: samwang    時間: 2021-7-8 13:31

回復 56# wang077

我現在做了一個listbox來裝篩選條件,但是只能抓到一個來篩選
有辦法抓多個條件來篩選嗎


不好意思,可以解釋清楚一點嗎? listbox裝篩選後的結果嗎?
但只能抓一個來篩選??
有辦法抓多個條件來篩選嗎??
作者: wang077    時間: 2021-7-8 14:19

回復 58# samwang
我的listbox裡面已經有篩選條件了
但我目前只能Select到1個值來篩選
我的問題是怎麼從listbox裡Select多個值來篩選
[attach]33534[/attach]
[attach]33535[/attach]
作者: wang077    時間: 2021-7-9 11:28

回復 34# samwang
大大,我現在把它丟進combobox裡
但我選了其中一個,卻會全部都叫出來
作者: samwang    時間: 2021-7-9 18:32

回復 59# wang077

請測試看看,謝謝

Private Sub CommandButton5_Click()
Dim ar2, s%
s = 0: ReDim ar2(s)
With Sheets("總表").Range("a2:u" & [a65536].End(3).Row)
    Sheets(1).AutoFilterMode = False
    For i = 0 To ListBox2.ListCount - 1
        If ListBox2.Selected(i) = True Then
            ReDim Preserve ar2(s)
            ar2(s) = CStr(ListBox2.List(i))
            s = s + 1
        End If
    Next
    .AutoFilter Field:=7, Criteria1:=ar2, Operator:=xlFilterValues
End With
Set ar2 = Nothing
End Sub
作者: wang077    時間: 2021-7-12 07:57

回復 61# samwang
測試過了,沒問題,謝謝大大




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)