返回列表 上一主題 發帖

[發問] 指定檔案 抓去個檔案間資料

回復 2# ounmaxz
  1. Sub Ex()
  2.     Dim Rng As Range, CopyRng As Range, I As Integer
  3.     Set Rng = Workbooks("工時整理.xlsm").Sheets(1).[a1]
  4.     For I = 1 To 16
  5.         With Workbooks.Open("Q:\M" & I & ".xlsx")
  6.             Set CopyRng = .Sheets(1).UsedRange.Offset(3)
  7.             Rng.Resize(CopyRng.Rows.Count, CopyRng.Columns.Count).Value = CopyRng.Value
  8.             Set Rng = Rng.Offset(IIf(I = 1, 999, 1000))
  9.             .Close False
  10.         End With
  11.     Next
  12. End Sub
複製代碼

TOP

回復 4# lilytracy
樓主說的:
小弟目前需整理很多人工時問題希望從[工時整理]檔內匯入 M1~M16 的檔案內容排序方式為

TOP

本帖最後由 GBKEE 於 2011-11-24 07:46 編輯

回復 6# davidoff
程式碼 改寫在一般模組 或ThisWorkbook模組
你的程式碼 是寫在 工作表物件模組   
Range 沒指明工作表 就是專屬於這工作表物件模組的工作表Range
你不能在其他工作表中 執行這 專屬於這工作表物件模組的工作表Range

TOP

回復 8# 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.             Set Rng = Rng.Offset(IIf(Rng.Row = 1, 999, 1000))
  12.             .Close False
  13.         End With
  14.     Next
  15. End Sub
複製代碼

TOP

回復 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
複製代碼

TOP

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

TOP

本帖最後由 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

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

TOP

        靜思自在 : 犯錯出懺悔心,才能清淨無煩惱。
返回列表 上一主題