VBA問題(從多個檔案抓取資料貼到單一檔案的不同sheet中)

1.有沒有辦法不打開檔案就成功複製資料

您的問題一，所謂的「不打開」，是指「真的」不去動該文件(open)？
幾個方向思考：
1.一般來說，如果使用VBA，open該檔案，取得其內容資料後，再命令其關閉，時間很短暫，使用者不大感覺到，這樣您是否可以接受？

Sub bb()
      Dim src As Workbook
      Set src = Workbooks.Open("f:\new.xlsx", True, True)
      ThisWorkbook.Activate
       '以下抓取資料
       ............
       src.Close
End Sub

檔案不是太大的話，一般使用者應該還能接受。
以下是網路上找到，有關的實際影片解說視頻(內容大同小異)：


2.如果堅持不open該檔，可以使用連結參照檔案的方式，在VBA或儲存格中，公式位置參照直接列出檔案路徑即可。
不過這種方式取得的內容，有可能是錯誤的(因未開啟，所以excel似乎就沒有對該檔案進行：開啟後自動重算或更新？)

3.另闢蹊徑~~使用其他方式來連接該檔：
ADO and the Excel ODBC driver(把Excel檔案當資料庫用)，或是python(不知是否能做到您的需求)
有google到一個網址，裡面有段話：

You can use ADO and the Excel ODBC driver to treat closed workbooks as databases. You can then use SQL to retrieve data. But it assumes that you have information laid out in tables with table headings. AFAIK that's the only way to deal with a spreadsheet without opening it.

ADO參考

若有興趣，您可以研究看看。

至於您的問題二：

meu00 wrote:
雖然有設定StrFileName 但是......

雖然我未能實際執行您的code，但個人注意到，您有2處用到dir()

meu00 wrote:
StrFileName = Dir(StrPathName & "\*POP表*.xls")

在該sub內約20行左右。

倒數第4~5行：

StrFileName = Dir()

照理來說，最後這個StrFileName = Dir()，應該會是要去找下一個檔案；但你在這2者之間，又用了一次Dir

.......
myname = Dir(mypath & myFile)
Do While myname <> ""
n = n + 1
myname = Dir
Loop
........

這部分您最好檢查一下，因為會造成錯誤發生，或是讀取檔案不正確。(更別說後續貼上正確資料了)

簡單直接的做法，是把你的第一個使用Dir：

StrFileName = Dir(StrPathName & "\*POP表*.xls")

這句挪到中間那第2個Dir()之後。這樣2個StrFileName 在進行Dir查詢時，中間沒有突然的「打岔」，才能順利傳回所有(用迴圈)檔案名稱。

以上簡單意見，提供您參考囉。(如果問題2能因此順利解決，也麻煩您抽空回應一下囉。)

meu00 wrote:
' Open the workbook with the filename
Dim wk As fil
Set wk = Workbooks.Open

myname = Dir(mypath & myFile)
Do While myname <> ""
n = n + 1
myname = Dir
Loop
 '-------(移到這？)
'set loop info
Dim b As Integer, a As Integer

'這幾句也得一起往下
' Open the workbook with the filename
Dim wk As fil
Set wk = Workbooks.Open

meu00 wrote:
1.有沒有辦法不打開檔案就成功複製資料
2.雖然有設定StrFileName 但是在試跑巨集時並沒有發揮作用

Sub test()
    
    Call delsheet '只保留工作表1，刪掉其它所有工作表
    
    Dim Get_Path As Object, Default_Path As Variant, xls_fullpath As Variant, pop As Workbook
 
    Default_Path = ThisWorkbook.Path
    Set Get_Path = CreateObject("Shell.Application").BrowseForFolder(0, "choose a folder", &H201, Default_Path)
     
    If Get_Path Is Nothing Then
        MsgBox "???"
        Exit Sub
    End If
        
    Application.DisplayAlerts = False
    For Each xls_fullpath In Get_Path.items
        DoEvents
        If xls_fullpath.Path Like "*pop表*.xls" And Not xls_fullpath.isfolder Then
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = "_" & xls_fullpath.Name & "_"
            
            Set pop = Workbooks.Open(xls_fullpath.Path, , False)
            '請自行練習修改資料範圍
            pop.Sheets("工作表1").Range("a1:a3").Copy ThisWorkbook.Sheets("_" & xls_fullpath.Name & "_").Range("a1:a3")
            pop.Close 1
            Set pop = Nothing
            
        End If
    Next
    Application.DisplayAlerts = True
    
    
    Set Get_Path = Nothing
    
End Sub



Sub delsheet()

    Dim delsheet() As Variant, i As Integer, j As Integer
    ReDim delsheet(1 To Worksheets.Count)
    Application.DisplayAlerts = False
    
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name <> "工作表1" Then '預設不刪除工作表1
            j = j + 1
            delsheet(j) = Worksheets(i).Name
        End If
    Next
    If j = 0 Then Exit Sub
    ReDim Preserve delsheet(1 To j)
    Worksheets(delsheet).Delete
    
    Application.DisplayAlerts = True

End Sub

misser wrote:
又或者，是您把要找來(恕刪)

meu00 wrote:
來源檔案只有一種就是資料夾中檔名有包含POP表的檔案

meu00 wrote:
另外您提供的dir調整有試過了，的確有解決問題謝謝您

snare wrote:
1、有，2樓說的方法(恕刪)

misser wrote:
所以我就是被您「騙」(恕刪)