GBKEE

回復 10# ounmaxz

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Rng As Range, NameRng As Range, CopyRng As Range, E As Range
   
4.     Set NameRng = Workbooks("工時整理.xlsm").Sheets(2).[A1:A16]    '人名的範圍 或是 完整的路徑檔案名稱
   
5.     Set Rng = Workbooks("工時整理.xlsm").Sheets(1).[a1]
   
6.     For Each E In NameRng
   
7.         With Workbooks.Open("Q:\" & E & ".xlsx")  'E=人名
   
8.         'With Workbooks.Open(E)   '如 E = 完整的路徑檔案名稱
   
9.             Set CopyRng = .Sheets(1).UsedRange.Offset(3)
   
10.             Rng.Resize(CopyRng.Rows.Count, CopyRng.Columns.Count).Value = CopyRng.Value
    
11.             If Rng.End(xlDown).Row = Rows.Count Then
    
12.                 Set Rng = Rng.End(xlDown).End(xlUp).Offset(1)
    
13.             Else
    
14.                 Set Rng = Rng.End(xlDown).Offset(1)
    
15.             End If
    
16.             .Close False
    
17.         End With
    
18.     Next
    
19. End Sub

複製代碼

davidoff

回復 7# GBKEE
感謝GBKEE版主的回答！
看完解答再經過實作之後，
有體認到程式碼寫在一般模組、Sheet模組及ThisWorkbook模組的差異。
看來省略的寫法真的要特別注意適用的模組類型。

ounmaxz

回復 11# GBKEE


    使用後兩種路徑選擇模式都顯示10004錯誤無法開啟檔案
    目前檔案室放在網路連線的磁碟內
    我使用錄製的路徑來做為索引的路徑
    套用到大大的程式裡卻找不到
    是我路徑選定有問題嗎

附上使用路徑
Q:\4A00維護課\內部控管\維修工時報工管理\2012年\M1.xlsx

GBKEE

回復 13# ounmaxz
上傳程式碼看看

ounmaxz

回復 14# GBKEE

上傳圖片比較容易說明
請看~~

   

下載 (87.35 KB)

2011-11-24 13:16

下載 (97.79 KB)

2011-11-24 13:16

以下程式碼是我用錄製的執行上OK

Workbooks.Open Filename:="Q:\4A00維護課\內部控管\維修工時報工管理\2012年\M1.xlsx"
    Range("A4:AD400").Select
    Selection.Copy
    Windows("123.xlsm").Activate
    Range("A3").Select
    ActiveSheet.Paste
    Windows("M1.xlsx").Activate
    ActiveWindow.Close

GBKEE

回復 15# ounmaxz
A1:A16 中如有空白 當然會有錯誤
Set NameRng = Workbooks("123.xlsm").Sheets(2).[A1:A16]   
改成   A1:A16 中有資料的程式碼
Set NameRng = Workbooks("123.xlsm").Sheets(2).[A1:A16].SpecialCells(xlCellTypeConstants)  
A1:A16 如全部是空白(沒有資料)也是一樣會有錯誤

ounmaxz

回復 16# GBKEE


    感謝大大不厭其煩地幫忙
   目前測試已能正常運作
    被路徑跟檔名套的團團轉:L

ounmaxz

回復 16# GBKEE


    目前使用上都沒有問題
只是螢幕會一直閃一直閃
能夠在程式執行時停止更新螢幕嗎
執行完再更新螢幕
不然一直閃眼睛好痛

Sub Ex()
    Dim Rng As Range, NameRng As Range, CopyRng As Range, E As Range
    Set NameRng = Workbooks("工時整理.xlsm").Sheets(5).[A2:A20].SpecialCells(xlCellTypeConstants)   '人名的範圍 或是 完整的路徑檔案名稱
    Set Rng = Workbooks("工時整理.xlsm").Sheets(1).[a3]
    For Each E In NameRng
        'With Workbooks.Open("Q:\" & E & ".xlsx")  'E=人名
        With Workbooks.Open(E)   '如 E = 完整的路徑檔案名稱
            Set CopyRng = .Sheets(1).UsedRange.Offset(3)
            Rng.Resize(CopyRng.Rows.Count, CopyRng.Columns.Count).Value = CopyRng.Value
            If Rng.End(xlDown).Row = Rows.Count Then
                Set Rng = Rng.End(xlDown).End(xlUp).Offset(1)
            Else
                Set Rng = Rng.End(xlDown).Offset(1)
            End If
            .Close False
        End With
    Next
End Sub

GBKEE

回復 18# ounmaxz
程式開始時  停止螢幕更新   Application.ScreenUpdating = False
程式結束前  恢復螢幕更新  Application.ScreenUpdating = True

ounmaxz

回復 19# GBKEE


    感謝GBKEE 大大的幫忙謝謝