返回列表 上一主題 發帖

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

兩個xls的工作表資料同步

問題一
假如我有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就會更新資料)

麻煩各位大大了

TOP

本帖最後由 lpk187 於 2015-11-4 15:30 編輯

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

TOP

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

TOP

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


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

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

回復 1# mark761222

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

TOP

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. For i = 0 To 1
  10.     Workbooks.Open (xlPath & xlFilea)
  11.     With Workbooks(xlFilea).Worksheets("工作表1")
  12.          Ro = .Cells(65535, 1).End(xlUp).Row + 1
  13.         .Cells(Ro, 1) = arra
  14.     End With
  15.     Workbooks(xlFilea).Close True
  16. Next
  17. For i = 0 To 1
  18.     Workbooks.Open (xlPath & xlFileb)
  19.     With Workbooks(xlFileb).Worksheets("工作表1")
  20.          Ro = .Cells(65535, 1).End(xlUp).Row + 1
  21.          .Cells(Ro, 1) = arrb
  22.     End With
  23.     Workbooks(xlFileb).Close True
  24. Next

  25. End Sub
複製代碼

TOP

回復 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 亦同上

TOP

回復 7# lpk187

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

謝謝你的指導!

TOP

回復 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.     Workbooks.Open (xlPath & xlFileb)
  20.     With Workbooks(xlFileb).Worksheets("工作表1")
  21.         Set da = .Columns(1).Find(arra(1, 1), , , , , 2)
  22.         If Not da Is Nothing Then GoTo 10
  23.         Ro = .Cells(65535, 1).End(xlUp).Row + 1
  24.         .Cells(Ro, 1) = arrb
  25.     End With
  26. 20:
  27.     Workbooks(xlFileb).Close True

  28. End Sub
複製代碼

TOP

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

TOP

        靜思自在 : 站在半路,比走到目標更辛苦。
返回列表 上一主題