返回列表 上一主題 發帖

[發問] vba開啟並抓取指定資料夾內關鍵字檔案&活頁名稱資料

[發問] vba開啟並抓取指定資料夾內關鍵字檔案&活頁名稱資料

擷取2.PNG
2018-2-6 22:44
擷取.PNG
2018-2-6 22:44

說明:
按下【按鈕1】時,自動開啟指定資料夾內檔案『list20180206135132.xls』 ,並將活頁名稱「list20180206135132」A:Z資料貼至此活頁A1,再將檔案『list20180206135132.xls』關閉

遇到問題:
檔案『list20180206135132.xls』除了 list 為固定字串,後面的日期時間數字均不固定,包含檔案內的活頁名稱也是一樣只有 list 為固定字串,後面的日期時間數字均不固定
因此巨集在寫的時候希望可以改為開啟指定關鍵字檔名『list』的檔案,例如list201802081532、list201803290915…以此類推,只要檔名有『list』關鍵字即符合條件,活頁名稱也是一樣

提醒:
指定資料夾內不只一個檔案,所以不能不指定檔名,否則有可能開到別的檔案了,以上求解~~~~~~~~~~


測試.rar (19.28 KB)
*宅女一枚無誤*

回復 11# Hsieh


   H大~~~~測試成功了喔!!!非常感謝~~~~~~~
*宅女一枚無誤*

TOP

回復 11# Hsieh


    H大~~~~首先非常非常非常感謝你熱心幫忙喔~~~~~~~不過測試結果為:
檔1『list*.xls』的Sheets(1)要匯入活頁「list報表」的A1:成功匯入
檔2『CCMOPQ*.xls』的Sheets(1)跟Sheets(2)要匯入活頁「有資料」的B1跟活頁「有資料2」的B1:Sheets(1)成功匯入「有資料」的B1Sheets(2)未匯入但匯入成Sheets(1)到「有資料2」的B1
檔3『CCMOP_NAME*.xls』的Sheets(1)跟Sheets(2)要匯入活頁「無資料」的B1跟活頁「無資料2」的B1:Sheets(1)成功匯入「無資料」的B1Sheets(2)未匯入但匯入成Sheets(1)到「無資料2」的B1
檔4『預約表單*.xls』的Sheets(4)要匯入活頁「預約表單」的A1:未匯入

可以再請你幫忙看看嗎~~~~~~
*宅女一枚無誤*

TOP

本帖最後由 Hsieh 於 2018-3-6 17:20 編輯

回復 10# msmplay
試試看
  1. Sub ex()
  2. Dim xlPath$
  3. xlPath = ThisWorkbook.Path
  4. Set fd = CreateObject("Scripting.Dictionary")
  5. fa = Array("list", "CCMOP_NAME", "CCMOP", "預約表單")
  6. sh = Array("list報表", "無資料", "無資料2", "有資料", "有資料2", "預約表單")
  7. an = Array(1, 1, 2, 1, 2, 4)
  8. For i = 0 To UBound(fa)
  9. f = Dir(xlPath & "\" & fa(i) & "*.xls")
  10. Do Until f = ""
  11. If fd.exists(f) = False Then
  12. fd(f) = f
  13.    With Workbooks.Open(xlPath & "\" & f)
  14.      If i = 0 Then
  15.         ar = Array(1)
  16.         ElseIf i = 1 Or i = 2 Then
  17.         ar = Array(1, 2)
  18.         Else
  19.         ar = Array(4)
  20.      End If
  21.      For j = 0 To UBound(ar)
  22.        With .Sheets(ar(j))
  23.        If k = 0 Or k = 5 Then Rng = "A1" Else Rng = "B1"
  24.           .Range("A1").CurrentRegion.Copy ThisWorkbook.Sheets(sh(k)).Range(Rng)
  25.        End With
  26.        k = k + 1
  27.      Next
  28.       .Close 0
  29.    End With
  30. End If
  31. f = Dir
  32. Loop
  33. Next
  34. End Sub
複製代碼
學海無涯_不恥下問

TOP

回復 8# GBKEE


   G大~~~~我自己大概試改了一下,可以請你幫我看看醬對不對嗎?但我已經盡力了............然後CCMOPQ*.xls我最後多加了一下Q,因為"CCMOPQ*.xls", "CCMOP_NAME*.xls"這兩個檔名前面不會完全一樣,抱歉

Option Explicit
Sub Ex()
    Dim xDir1 As String, xDir2 As String, xDir3 As String, xPath As String, xWb1 As Workbook, xWb2 As Workbook, xWb3 As Workbook
    Dim Sh1(), Sh2(), Dir_Ar1(), Dir_Ar2(), xRng1(), xRng2(), i As Integer
    Dir_Ar1 = Array("list*.xls", "CCMOPQ*.xls", "CCMOP_NAME*.xls")
    Dir_Ar2 = Array("CCMOPQ*.xls", "CCMOP_NAME*.xls")
    Sh1 = Array("list報表", "有資料1", "無資料1")
    Sh2 = Array("有資料2", "無資料2")
    xRng1 = Array("A1", "B1", "B1")
    xRng2 = Array("B1", "B1")
    xPath = ThisWorkbook.Path
    For i = 0 To UBound(Sh1)
        xDir1 = Dir(xPath & "\" & Dir_Ar1(i), vbDirectory)
        Do While xDir1 <> ""
            If i = UCase(xDir1) Then GoTo xNext1
            Set xWb1 = Workbooks.Open(xPath & "\" & xDir1)
            With ThisWorkbook.Sheets(Sh1(i)).Range(xRng1(i)).End(xlDown)
                If .Row = .Parent.Rows.Count Then
                    xWb1.Sheets(1).UsedRange.Copy .Cells.End(xlUp)
                Else
                    xWb1.Sheets(1).UsedRange.Copy .Cells.Offset(1)
                End If
            End With
            xWb1.Close
xNext1:
            xDir1 = Dir
        Loop
    Next
    For i = 0 To UBound(Sh2)
        xDir2 = Dir(xPath & "\" & Dir_Ar2(i), vbDirectory)
        Do While xDir2 <> ""
            If i = UCase(xDir2) Then GoTo xNext2
            Set xWb2 = Workbooks.Open(xPath & "\" & xDir2)
            With ThisWorkbook.Sheets(Sh2(i)).Range(xRng2(i)).End(xlDown)
                If .Row = .Parent.Rows.Count Then
                    xWb2.Sheets(2).UsedRange.Copy .Cells.End(xlUp)
                Else
                    xWb2.Sheets(2).UsedRange.Copy .Cells.Offset(1)
                End If
            End With
            xWb2.Close
xNext2:
            xDir2 = Dir
        Loop
    Next
    xDir3 = Dir(xPath & "\預約表單*.xls", vbDirectory)
    Do While xDir3 <> ""
    Set xWb3 = Workbooks.Open(xPath & "\" & xDir3)
    With ThisWorkbook.Sheets("預約表單").Range("A1").End(xlDown)
        If .Row = .Parent.Rows.Count Then
            xWb3.Sheets("預約表單系統資料").UsedRange.Copy .Cells.End(xlUp)
        Else
            xWb3.Sheets("預約表單系統資料").UsedRange.Copy .Cells.Offset(1)
        End If
            End With
            xWb3.Close
            xDir3 = Dir
        Loop
End Sub
*宅女一枚無誤*

TOP

回復 8# GBKEE


   哈~~~~~G大,對不起~~~~小妹又來煩你了,因為不管自己怎麼亂改就是不會成功,可以再請你幫我個忙嗎~~~~~~就是上次4#的問題,如果想再多加以下條件,到底該怎麼修改才對呢??因為發現不同的報表有不同需求.........

一樣是4個檔案要匯入,但條件如下:
檔1『list*.xls』的Sheets(1)要匯入活頁「list報表」的A1
檔2『CCMOP*.xls』Sheets(1)跟Sheets(2)要匯入活頁「有資料」的B1跟活頁「有資料2」的B1
檔3『CCMOP_NAME*.xls』Sheets(1)跟Sheets(2)要匯入活頁「無資料」的B1跟活頁「無資料2」的B1
檔4『預約表單*.xls』Sheets(4)要匯入活頁「預約表單」的A1
*宅女一枚無誤*

TOP

回復 7# jeffrey628litw
粗心大意,感謝指出,
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復  msmplay
GBKEE 發表於 2018-2-11 08:33



    大師 有小筆誤 :第11列 Aeray 是Array 哦

TOP

回復 5# GBKEE


   G大好厲害ㄛ你!真是超級感謝你的熱血幫忙ㄛ
*宅女一枚無誤*

TOP

本帖最後由 GBKEE 於 2018-2-15 07:55 編輯

回復 4# msmplay
  1. '檔1『list*.xls』要匯入活頁「list報表」的A1
  2. '檔2『CCMOP*.xls』要匯入活頁「有資料」的B1
  3. '檔3『CCMOP_NAME*.xls』要匯入活頁「無資料」的B1
  4. '檔4『預約表單*.xls』要匯入活頁「預約表單」的A1
  5. Option Explicit
  6. Sub Ex()
  7.     Dim xDir As String, xPath As String, xWb As Workbook
  8.     Dim Sh(), Dir_Ar(), xRng(), i As Integer
  9.     Dir_Ar = Array("list*.xls", "CCMOP*.xls", "CCMOP_NAME*.xls", "預約表單*.xls")
  10.     Sh = Array("list報表", "有資料", "無資料", "預約表單")
  11.     xRng = Arry("A1", "B1", "B1", "A1")
  12.     xPath = ThisWorkbook.Path
  13.     For i = 0 To UBound(Sh)
  14.         xDir = Dir(xPath & "\" & Dir_Ar(i), vbDirectory)
  15.         Do While xDir <> ""
  16.             If i = 1 And InStr(UCase(xDir), "CCMOP_NAME") Then GoTo xNext
  17.             Set xWb = Workbooks.Open(xPath & "\" & xDir)
  18.             With ThisWorkbook.Sheets(Sh(i)).Range(xRng(i)).End(xlDown)
  19.                 If .Row = .Parent.Rows.Count Then
  20.                     xWb.Sheets(1).UsedRange.Copy .Cells.End(xlUp)
  21.                 Else
  22.                     xWb.Sheets(1).UsedRange.Copy .Cells.Offset(1)
  23.                 End If
  24.             End With
  25.             xWb.Close
  26. xNext:
  27.             xDir = Dir
  28.         Loop
  29.     Next
  30. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 道德是提昇自我的明燈,不該是呵斥別人的鞭子。
返回列表 上一主題