Hsieh

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

複製代碼

msmplay

回復 11# Hsieh


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

可以再請你幫忙看看嗎~~~~~~

msmplay

回復 11# Hsieh


   H大~~~~測試成功了喔!!!非常感謝~~~~~~~