返回列表 上一主題 發帖

VBA 抓取ListBox中的內容

回復 20# wang077


請測試看看,謝謝

test2.zip (139.96 KB)

TOP

回復 21# samwang
大大,我的權限不夠,沒辦法载下來,可以傳到我的mail嗎?
mail:a0975215828@gmail.com

TOP

回復 22# wang077


已寄出,請確認,謝謝

TOP

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

TOP

回復 9# samwang
大大不好意思,小弟有另一個問題
彙整.zip (231.23 KB)
如何把機1與機2兩個excel的sheet1資料用VBA彙整到新的excel裡的sheet1
已附上範例

TOP

回復 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

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

TOP

回復 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

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

TOP

本帖最後由 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

        靜思自在 : 口說好話、心想好意、身行好事。
返回列表 上一主題