VBA 抓取ListBox中的內容

samwang

大學生 Rank: 4

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

21^# 跳轉到 »

發表於 2021-7-1 19:29 | 只看該作者

回復 20# wang077

請測試看看，謝謝

test2.zip (139.96 KB)

TOP

wang077

中學生 Rank: 2

帖子: 104
主題: 10
精華: 0
積分: 114
點名: 0
作業系統: Windows 10
軟體版本: Office 2007
閱讀權限: 20
性別: 男
註冊時間: 2021-6-21
最後登錄: 2021-8-24

22^#

發表於 2021-7-2 07:51 | 只看該作者

回復 21# samwang
大大，我的權限不夠，沒辦法载下來，可以傳到我的mail嗎?
mail:[email protected]

TOP

samwang

大學生 Rank: 4

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

23^#

發表於 2021-7-2 10:20 | 只看該作者

回復 22# wang077

已寄出，請確認，謝謝

TOP

wang077

中學生 Rank: 2

帖子: 104
主題: 10
精華: 0
積分: 114
點名: 0
作業系統: Windows 10
軟體版本: Office 2007
閱讀權限: 20
性別: 男
註冊時間: 2021-6-21
最後登錄: 2021-8-24

24^#

發表於 2021-7-2 11:05 | 只看該作者

回復 23# samwang
收到了，感謝幫忙。

TOP

wang077

中學生 Rank: 2

帖子: 104
主題: 10
精華: 0
積分: 114
點名: 0
作業系統: Windows 10
軟體版本: Office 2007
閱讀權限: 20
性別: 男
註冊時間: 2021-6-21
最後登錄: 2021-8-24

25^#

發表於 2021-7-2 16:07 | 只看該作者

回復 9# samwang
大大不好意思，小弟有另一個問題

彙整.zip (231.23 KB)
如何把機1與機2兩個excel的sheet1資料用VBA彙整到新的excel裡的sheet1
已附上範例

TOP

samwang

大學生 Rank: 4

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

26^#

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

wang077

中學生 Rank: 2

帖子: 104
主題: 10
精華: 0
積分: 114
點名: 0
作業系統: Windows 10
軟體版本: Office 2007
閱讀權限: 20
性別: 男
註冊時間: 2021-6-21
最後登錄: 2021-8-24

27^#

發表於 2021-7-5 08:00 | 只看該作者

回復 26# samwang
測試過了，沒問題，非常感謝大大
大大可以稍微解釋一下這些程式碼嗎
小弟能力較差，需要理解

TOP

samwang

大學生 Rank: 4

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

28^#

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

wang077

中學生 Rank: 2

帖子: 104
主題: 10
精華: 0
積分: 114
點名: 0
作業系統: Windows 10
軟體版本: Office 2007
閱讀權限: 20
性別: 男
註冊時間: 2021-6-21
最後登錄: 2021-8-24

29^#

發表於 2021-7-5 09:16 | 只看該作者

回復 26# samwang

彙整.zip (804.22 KB)
大大，你可以幫我看一下嗎
彙整過去的資料有些格式會跑掉
然後，有辦法連函數一起會整過去嗎

TOP

samwang

大學生 Rank: 4

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

30^#

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

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

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