指定檔案抓去個檔案間資料 - Excel程式區

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

11^# 跳轉到 »

發表於 2011-11-24 09:37 | 只看該作者

回復 10# ounmaxz

Option Explicit
Sub Ex()
Dim Rng As Range, NameRng As Range, CopyRng As Range, E As Range
Set NameRng = Workbooks("工時整理.xlsm").Sheets(2).[A1:A16] '人名的範圍或是完整的路徑檔案名稱
Set Rng = Workbooks("工時整理.xlsm").Sheets(1).[a1]
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

複製代碼

TOP

davidoff

中學生 Rank: 2

帖子: 10
主題: 0
精華: 0
積分: 50
點名: 0
作業系統: win7
軟體版本: office2003
閱讀權限: 20
註冊時間: 2011-11-23
最後登錄: 2012-11-27

12^#

發表於 2011-11-24 10:06 | 只看該作者

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

TOP

ounmaxz

小學生 Rank: 1

帖子: 19
主題: 4
精華: 0
積分: 35
點名: 0
作業系統: windows XP sp3
軟體版本: office 2007
閱讀權限: 10
性別: 男
來自: 台灣
註冊時間: 2010-6-10
最後登錄: 2013-8-6

13^#

發表於 2011-11-24 11:08 | 只看該作者

回復 11# GBKEE

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

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

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

14^#

發表於 2011-11-24 11:36 | 只看該作者

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

TOP

ounmaxz

小學生 Rank: 1

帖子: 19
主題: 4
精華: 0
積分: 35
點名: 0
作業系統: windows XP sp3
軟體版本: office 2007
閱讀權限: 10
性別: 男
來自: 台灣
註冊時間: 2010-6-10
最後登錄: 2013-8-6

15^#

發表於 2011-11-24 13:17 | 只看該作者

本帖最後由 ounmaxz 於 2011-11-24 13:26 編輯

回復 14# GBKEE

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

以下程式碼是我用錄製的執行上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

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

16^#

發表於 2011-11-24 14:18 | 只看該作者

本帖最後由 GBKEE 於 2011-11-24 14:20 編輯

回復 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 如全部是空白(沒有資料)也是一樣會有錯誤

TOP

ounmaxz

小學生 Rank: 1

帖子: 19
主題: 4
精華: 0
積分: 35
點名: 0
作業系統: windows XP sp3
軟體版本: office 2007
閱讀權限: 10
性別: 男
來自: 台灣
註冊時間: 2010-6-10
最後登錄: 2013-8-6

17^#

發表於 2011-11-24 14:56 | 只看該作者

回復 16# GBKEE

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

TOP

ounmaxz

小學生 Rank: 1

帖子: 19
主題: 4
精華: 0
積分: 35
點名: 0
作業系統: windows XP sp3
軟體版本: office 2007
閱讀權限: 10
性別: 男
來自: 台灣
註冊時間: 2010-6-10
最後登錄: 2013-8-6

18^#

發表於 2011-11-25 11:16 | 只看該作者

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

TOP

GBKEE