VBA 抓取ListBox中的內容

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-1-10

11^# 跳轉到 »

發表於 2021-7-2 10:20 | 顯示全部帖子

回復 22# wang077

已寄出，請確認，謝謝

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-1-10

12^#

發表於 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

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-1-10

13^#

發表於 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

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-1-10

14^#

發表於 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

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-1-10

15^#

發表於 2021-7-6 07:47 | 顯示全部帖子

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

回復 31# wang077 [/

將需要複製的檔案放在某個資料夾
開啟表單後選取那個資料夾
會自動顯示出那個資料裡的檔案名稱
選取檔名然後複製
請測試看看
謝謝

彙整_0706.zip (67.92 KB)

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-1-10

16^#

發表於 2021-7-6 08:41 | 顯示全部帖子

回復 35# wang077

已寄給您了，謝謝

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-1-10

17^#

發表於 2021-7-6 17:39 | 顯示全部帖子

回復 39# wang077

如果開啟表單後要直接把機1，機2叫出來在ListBox上呢，等於不要有選擇資料夾這步驟
>> 因為要選取資料夾才能得知有哪些檔案，不然無法知道有那些檔名，如機1，機2、機3...等等

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-1-10

18^#

發表於 2021-7-6 20:14 | 顯示全部帖子

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

回復 41# wang077

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

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-1-10

19^#

發表於 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

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-1-10

20^#

發表於 2021-7-7 13:43 | 顯示全部帖子

回復 48# wang077

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

TOP

[收藏此主題] [關注此主題的新回復]

[通過 QQ、MSN 分享給朋友]