Hsieh

回復 2# PJChen

貼上的位置是庫存檔案的位置，若原來庫存的筆數不同該如何處理?
若筆數相同就會直接覆蓋原有資料，這是你的需求嗎?
若筆數教員資料多，則會影響不同準則的資料，這些跟庫存觀念好像都不符合

Hsieh

回復 4# PJChen

參考看看

1. Sub copy_all()
   
2. Dim ws() '已經開啟視窗
   
3. books = Array("庫存資料表.xlsx", "庫存.xlsx") '欲開啟檔案
   
4. mypath = ThisWorkbook.Path '存放檔案資料夾
   
5. For Each w In Windows '已經開啟視窗
   
6.    ReDim Preserve ws(s)
   
7.    ws(s) = w.Caption
   
8.    s = s + 1
   
9. Next
   
10. For Each b In books '測試檔案是否開啟
    
11.    If UBound(Filter(ws, b)) = -1 Then Workbooks.Open (mypath & "\" & b) '檔案未開啟則開啟
    
12. Next
    
13. x = ThisWorkbook.Sheets(1).[H2] '準則
    
14. With Workbooks(books(0)) '庫存資料表.xlsx
    
15.     Set a = .Sheets(1).Columns("D").Find(x, lookat:=xlWhole) '找準則位置
    
16.     If a Is Nothing Then MsgBox "找不到準則位置": End
    
17.     k = Application.CountIf(a.EntireColumn, x) '合乎準則列數
    
18.     Set Rng = .Sheets(1).Cells(a.Row, "B").Resize(k, 26) 'B:AA欄資料
    
19.     With Workbooks(books(1)) '庫存.xlsx
    
20.        k1 = Application.CountIf(.Sheets(1).Columns("D"), x) '合乎準則列數
    
21.        Set a = .Sheets(1).Columns("D").Find(x, lookat:=xlWhole) '找準則位置
    
22.        If a Is Nothing Then Set a = .Sheets(1).Cells(.Sheets(1).Rows.Count, 4).End(xlUp).Offset(1) '原資料不存在準則資料
    
23.        yn = MsgBox("原資料" & k1 & "列，新資料" & k & "列，是否複製?", vbYesNo)
    
24.        If yn = 6 Then
    
25.           a.Offset(, -2).Resize(k, 26).Value = Rng.Value '寫入新資料
    
26.           MsgBox "資料已更新"
    
27.         Else
    
28.           MsgBox "資料未更新", 48
    
29.        End If
    
30.     End With
    
31. End With
    
32. End Sub

複製代碼

Hsieh

回復 6# PJChen

1. Sub copy_all()
   
2. Dim ws() '已經開啟視窗
   
3. books = Array("庫存資料表.xlsx", "庫存.xlsx") '欲開啟檔案
   
4. mypath = ThisWorkbook.Path '存放檔案資料夾
   
5. For Each w In Windows '已經開啟視窗
   
6.    ReDim Preserve ws(s)
   
7.    ws(s) = w.Caption
   
8.    s = s + 1
   
9. Next
   
10. For Each b In books '測試檔案是否開啟
    
11.    If UBound(Filter(ws, b)) = -1 Then Workbooks.Open (mypath & "\" & b) '檔案未開啟則開啟
    
12. Next
    
13. x = ThisWorkbook.Sheets(1).[H2] '準則
    
14. With Workbooks(books(0)).Sheets(1) '庫存資料表.xlsx
    
15.     Set a = .Columns("D").Find(x, lookat:=xlWhole) '找準則位置
    
16.     If a Is Nothing Then MsgBox "找不到準則位置": End
    
17.     Set Rng = .Range(a.Offset(, -2), a.End(xlDown).Offset(, 23)) 'B:AA欄資料
    
18.     MsgBox Rng.Address
    
19.     With Workbooks(books(1)).Sheets(1) '庫存.xlsx
    
20.        Set a = .Columns("D").Find(x, lookat:=xlWhole) '找準則位置
    
21.        If a Is Nothing Then Set a = .Cells(.Rows.Count, 4).End(xlUp).Offset(1) '原資料不存在準則資料
    
22.        .Range("A" & a.Row & ":AA" & .Rows.Count).ClearContents
    
23.           a.Offset(, -2).Resize(Rng.Rows.Count, 26).Value = Rng.Value '寫入新資料
    
24.           a.Offset(, -3).Resize(Rng.Rows.Count, 1) = Rng.Columns(5).Value '寫入A欄編號
    
25.           MsgBox "資料已更新"
    
26.     End With
    
27. End With
    
28. End Sub

複製代碼