1234567
返回列表 上一主題 發帖

VBA 抓取ListBox中的內容

wang077

帖子
104 
主題
10 
精華
0 
積分
114 
點名
0  
作業系統
Windows 10 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2021-6-21 
最後登錄
2021-8-24 
53# 跳轉到 »
發表於 2021-7-7 16:28 | 只看該作者
回復 52# samwang
我後來直接在dbl_Click
下了Unload
再下show
把form重新show一次
就可以了
可以一次多選，選完2個機台後在listbox裡的空白處點兩下就好了

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2024-5-16 
52#
發表於 2021-7-7 16:11 | 只看該作者
回復 51# wang077


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

原程式架構: listbox 設為複選，選擇機號，機號暫存Ar數組-->用commandbutton 執行迴圈Ar去做複製動作

TOP

wang077

帖子
104 
主題
10 
精華
0 
積分
114 
點名
0  
作業系統
Windows 10 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2021-6-21 
最後登錄
2021-8-24 
51#
發表於 2021-7-7 14:22 | 只看該作者
回復 50# samwang
彙整_0707.zip (117.42 KB)
新增資料夾.zip (407.42 KB)
麻煩大大了

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2024-5-16 
50#
發表於 2021-7-7 13:43 | 只看該作者
回復 48# wang077


我測試沒問題，可附件讓我測試看看嗎? 謝謝

TOP

wang077

帖子
104 
主題
10 
精華
0 
積分
114 
點名
0  
作業系統
Windows 10 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2021-6-21 
最後登錄
2021-8-24 
49#
發表於 2021-7-7 11:04 | 只看該作者
回復 47# s3526369
此問題已解決
感謝分享

TOP

wang077

帖子
104 
主題
10 
精華
0 
積分
114 
點名
0  
作業系統
Windows 10 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2021-6-21 
最後登錄
2021-8-24 
48#
發表於 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的時候
他又顯示這錯誤了
求解！

TOP

s3526369
　暱稱: 大榮

中學生Rank: 2

帖子
45 
主題
3 
精華
0 
積分
72 
點名
0  
作業系統
WIN7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2018-2-12 
最後登錄
2024-3-9 
47#
發表於 2021-7-7 10:12 | 只看該作者
回復 1# wang077
  1. With ListBox1
  2.           .ListStyle = 1  '序前方框框
  3. End With
複製代碼

TOP

wang077

帖子
104 
主題
10 
精華
0 
積分
114 
點名
0  
作業系統
Windows 10 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2021-6-21 
最後登錄
2021-8-24 
46#
發表於 2021-7-7 09:10 | 只看該作者
回復 45# wang077
找到錯誤了，剛剛把程式檔放再同一個資料夾，所以出現錯誤
以解決這錯誤

TOP

wang077

帖子
104 
主題
10 
精華
0 
積分
114 
點名
0  
作業系統
Windows 10 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2021-6-21 
最後登錄
2021-8-24 
45#
發表於 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))
這行出現了錯誤

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2024-5-16 
44#
發表於 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

TOP

        靜思自在 : 人生不一定球球是好球，但是有歷練的強打者，隨時都可以揮棒。
1234567
返回列表 上一主題