[發問] 將資料寫入到其他多個EXCEL檔案

mark761222

問題一
假如我有A.xlsx  與B.xlsm (巨集檔)
A.xlsx 有工作表1

B.xlsm 有工作表1，要去抓取所有A的所有工作表1內容到B工作表1 (只要A.xlsx資料有更新B就會更新資料)

問題二

假如我有A.xlsx  與B.xlsm (巨集檔)
A.xlsx 有工作表1

B.xlsm 有工作表1，要去抓取所有A工作表1裡面整合內容如 B整行、D整行、E整行 到B工作表1的 A整行、B整行、C整行 (只要A.xlsx資料有更新B就會更新資料)

麻煩各位大大了

lpk187

回復 1# mark761222

首先必須說明，兩個xls的工作表資料不可能同步！！就算同時更新時，也不能稱為同步！就算程式碼寫在a檔案，也一樣，都會有例外的時候，所以只能以程式來讀取a檔案的最新資料而已，下面程式碼也只是讀取最新資料，而不能稱之為"同步"
其2個問題程式碼如下：

1. Public Sub ex1()
   
2.     Sheets("工作表1").UsedRange.ClearContents
   
3.     Dim xlPath As Variant, xlFile As Variant
   
4.     Dim arr
   
5.     xlPath = ThisWorkbook.Path & "\"
   
6.     xlFile = "a.xlsx"
   
7.     Workbooks.Open (xlPath & xlFile)
   
8.     arr = Workbooks(xlFile).Worksheets("工作表1").UsedRange
   
9.     Workbooks(xlFile).Close True
   
10.     Sheets("工作表1").[A1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
11. End Sub
    
12. Public Sub ex2()
    
13.     Sheets("工作表1").UsedRange.ClearContents
    
14.     Dim xlPath As Variant, xlFile As Variant
    
15.     Dim Barr, Darr, Earr
    
16.     xlPath = ThisWorkbook.Path & "\"
    
17.     xlFile = "a.xlsx"
    
18.     Workbooks.Open (xlPath & xlFile)
    
19.     With Workbooks(xlFile).Worksheets("工作表1")
    
20.         Barr = .Range("B1", .Cells(65535, "B").End(xlUp))
    
21.         Darr = .Range("D1", .Cells(65535, "D").End(xlUp))
    
22.         Earr = .Range("E1", .Cells(65535, "E").End(xlUp))
    
23.     End With
    
24.     Workbooks(xlFile).Close True
    
25.     With Sheets("工作表1")
    
26.         .[A1].Resize(UBound(Barr)) = Barr
    
27.         .[B1].Resize(UBound(Darr)) = Darr
    
28.         .[C1].Resize(UBound(Earr)) = Earr
    
29.     End With
    
30. End Sub

複製代碼

mark761222

感謝lpk187!
正在努力理解你寫的程式架構

mark761222

下載 (56.64 KB)

2015-11-5 02:34

我有三個EXCEL檔案分別為A B C 如圖
A為計算檔案透過按鈕將資料傳送到B 與 C
判斷B 與 C資料最後一筆資料並填上

有大哥大姐寫過類式的程式嗎

lpk187

回復 1# mark761222

請參考
http://minyeh187.pixnet.net/blog/post/166816531

mark761222

TO lpk187
又遇到問題了，稍微改了一下程式
假設A 工作表有2筆資料 A1:E1 要送資料到B
A2:E2要送資料C
改了以下程式，但是只傳送日期，內容不會傳送，而且日期還重複2次，是哪裡理解錯誤了嗎

不好意思一值麻煩你

1. Private Sub Workbook_Open()
   
2. Dim xlPath As Variant, Ro As Integer
   
3. Dim xlFilea, xlFileb, arra, arrb
   
4.     xlPath = ThisWorkbook.Path & "\"
   
5. xlFilea = ("B.xlsx")
   
6. xlFileb = ("C.xlsx")
   
7. arra = Sheets("工作表1").Range("A1:E1")
   
8. arrb = Sheets("工作表1").Range("A2:E2")
   
9. 
   
10. For i = 0 To 1
    
11.     Workbooks.Open (xlPath & xlFilea)
    
12.     With Workbooks(xlFilea).Worksheets("工作表1")
    
13.          Ro = .Cells(65535, 1).End(xlUp).Row + 1
    
14.         .Cells(Ro, 1) = arra
    
15.     End With
    
16.     Workbooks(xlFilea).Close True
    
17. Next
    
18. For i = 0 To 1
    
19.     Workbooks.Open (xlPath & xlFileb)
    
20.     With Workbooks(xlFileb).Worksheets("工作表1")
    
21.          Ro = .Cells(65535, 1).End(xlUp).Row + 1
    
22.          .Cells(Ro, 1) = arrb
    
23.     End With
    
24.     Workbooks(xlFileb).Close True
    
25. Next
    
26. 
    
27. End Sub

複製代碼

lpk187

回復 6# mark761222


   日期還重複2次是你多寫了 For i = 0 To 1 ，把2個For i = 0 To 1...Next刪了吧！
致於為什麼只傳送日期，內容不會傳送
則是.Cells(Ro, 1) = arra 錯誤，你應該要多加Resize範圍給它
.Cells(Ro, 1).Resize(Ubound(arra),Ubound(arra,2)) = arra
.Cells(Ro, 1) = arrb 亦同上

mark761222

回復 7# lpk187

謝謝!真的可以了，如果要加上驗證機制應該很難吧
例如A 2015/11/6去偵測B 2015/11/6 與C 2015/11/6  如果有這個日期不新增，有的話新增

謝謝你的指導!

lpk187

回復 8# mark761222

試試看

1. Private Sub Workbook_Open()
   
2. Dim xlPath As Variant, Ro As Integer
   
3. Dim xlFilea, xlFileb, arra, arrb
   
4.     xlPath = ThisWorkbook.Path & "\"
   
5. xlFilea = ("B.xlsx")
   
6. xlFileb = ("C.xlsx")
   
7. arra = Sheets("工作表1").Range("A1:E1")
   
8. arrb = Sheets("工作表1").Range("A2:E2")
   
9.     Workbooks.Open (xlPath & xlFilea)
   
10.     With Workbooks(xlFilea).Worksheets("工作表1")
    
11.         Set da = .Columns(1).Find(arra(1, 1), , , , , 2)
    
12.         If Not da Is Nothing Then GoTo 10
    
13.          Ro = .Cells(65535, 1).End(xlUp).Row + 1
    
14.          
    
15.         .Cells(Ro, 1) = arra
    
16.     End With
    
17. 10:
    
18.     Workbooks(xlFilea).Close True
    
19. 
    
20.     Workbooks.Open (xlPath & xlFileb)
    
21.     With Workbooks(xlFileb).Worksheets("工作表1")
    
22.         Set da = .Columns(1).Find(arra(1, 1), , , , , 2)
    
23.         If Not da Is Nothing Then GoTo 10
    
24.         Ro = .Cells(65535, 1).End(xlUp).Row + 1
    
25.         .Cells(Ro, 1) = arrb
    
26.     End With
    
27. 20:
    
28.     Workbooks(xlFileb).Close True
    
29. 
    
30. End Sub

複製代碼

mark761222

夭壽!越來越複雜，都快看不懂了= =
可以幫忙註解一下嗎@@