返回列表 上一主題 發帖

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

lpk187

帖子
552 
主題
6 
精華
0 
積分
576 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2015-2-8 
最後登錄
2026-9-10 

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
1# 跳轉到 »
發表於 2015-11-4 15:27 | 顯示全部帖子
本帖最後由 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

帖子
552 
主題
6 
精華
0 
積分
576 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2015-2-8 
最後登錄
2026-9-10 

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
2#
發表於 2015-11-5 06:25 | 顯示全部帖子
回復 1# mark761222

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

TOP

lpk187

帖子
552 
主題
6 
精華
0 
積分
576 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2015-2-8 
最後登錄
2026-9-10 

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
3#
發表於 2015-11-6 09:31 | 顯示全部帖子
回復 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

lpk187

帖子
552 
主題
6 
精華
0 
積分
576 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2015-2-8 
最後登錄
2026-9-10 

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
4#
發表於 2015-11-6 13:51 | 顯示全部帖子
回復 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

  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

  30. End Sub
複製代碼

TOP

lpk187

帖子
552 
主題
6 
精華
0 
積分
576 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2015-2-8 
最後登錄
2026-9-10 

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
5#
發表於 2015-11-7 08:22 | 顯示全部帖子
回復 11# mark761222

可以的話，請附上你的範例檔案上來，而且是你最終目的的範例檔，目的不同，就算只有些許的改變，可能程式都要大幅的改變，就像11樓的問題，和之前的寫法大部份會不一樣！
甚至可以的話在範例檔中請附上C欄及F欄的公式！

TOP

lpk187

帖子
552 
主題
6 
精華
0 
積分
576 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2015-2-8 
最後登錄
2026-9-10 

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
6#
發表於 2015-11-10 22:39 | 顯示全部帖子
回復 14# mark761222


    有2種方式，請自行測試，選擇自己的需求，一種為有函數的儲存格就寫入函數，但鑑於有可能做微調故有第二種方式，跳過有函數的儲存格
  1. Option Explicit
  2. Sub Ex() '方式1為寫入函數
  3.     Dim xlPath As Variant, xlFile As Variant
  4.     Dim Rng As Range, Rn As Range, Ran As Range, ch As Range
  5.     Dim myCol As Integer, myRow As Integer, k As Integer
  6.     Dim xlRo As Integer
  7.     Dim arr
  8.     xlPath = ThisWorkbook.Path & "\" '讀取本程式檔的路徑
  9.     xlFile = "每日更新接收.xlsx" '讀取本程式檔名稱
  10.     With ThisWorkbook.Sheets("工作表1")
  11.         myCol = .Cells(1, Columns.Count).End(xlToLeft).Column '查詢工作表1的最後一欄位置
  12.         myRow = .Cells(Rows.Count, 1).End(xlUp).Row '查詢工作表1的最後一列位置
  13.         For Each Rng In .Range("A2", .Cells(myRow, 1)) '此迴圈做 有資料Range位置的聯集 Union
  14.             If Rng <> "" Then
  15.                 k = k + 1
  16.                 If k = 1 Then
  17.                     Set Rn = Rng
  18.                 Else
  19.                     Set Rn = Union(Rn, Rng)
  20.                 End If
  21.             End If
  22.         Next
  23.     End With
  24.     Workbooks.Open (xlPath & xlFile) '打開"每日更新接收.xlsx"活頁簿
  25.     For Each Ran In Rn
  26.         With Workbooks(xlFile).Sheets(Ran.Value)
  27.             Set ch = .Columns(1).Find(Ran.Offset(, 1), LookAt:=xlWhole, SearchDirection:=2)
  28.             '檢查日期是否有重複，當ch變數為Nothing時，則無發現重複日期，否則離開這一次的資料儲存，並執行下一個迴圈
  29.             If Not ch Is Nothing Then MsgBox Ran & "工作表中的" & ch & "資料已存在，不會儲存資料": Set ch = Nothing: GoTo 10
  30.             arr = Ran.Offset(, 1).Resize(, myCol - 1)
  31.             ''''把公式替換陣列中的值'''
  32.             arr(1, 5) = "=SUM(RC[5]:RC[13])"
  33.             arr(1, 6) = "=1-RC[-1]/RC[-2]"
  34.             arr(1, 8) = "=SUM(RC[12]:RC[18])"
  35.             arr(1, 9) = "=1-RC[-1]/RC[-2]"
  36.             arr(1, 29) = "=SUM(RC[5]:RC[10])"
  37.             arr(1, 30) = "=1-RC[-1]/RC[-2]"
  38.             arr(1, 48) = "=SUM(RC[2]:RC[11])"
  39.             arr(1, 49) = "=1-RC[-1]/RC[-2]"
  40.             ''''
  41.             xlRo = .Cells(Rows.Count, 1).End(xlUp).Row + 1
  42.             .Cells(xlRo, 1).Resize(, UBound(arr, 2)) = arr '寫入資料
  43.         End With
  44. 10:
  45.     Next
  46.     Workbooks(xlFile).Close True '關閉"每日更新接收.xlsx"活頁簿
  47. End Sub

  49. Sub Ex1() '不寫入函數跳過有函數的儲存格
  50.     Dim xlPath As Variant, xlFile As Variant
  51.     Dim Rng As Range, Rn As Range, Ran As Range, ch As Range
  52.     Dim myCol As Integer, myRow As Integer, k As Integer, I As Integer
  53.     Dim xlRo As Integer
  54.     Dim arr
  55.     xlPath = ThisWorkbook.Path & "\" '讀取本程式檔的路徑
  56.     xlFile = "每日更新接收.xlsx" '讀取本程式檔名稱
  57.     With ThisWorkbook.Sheets("工作表1")
  58.         myCol = .Cells(1, Columns.Count).End(xlToLeft).Column '查詢工作表1的最後一欄位置
  59.         myRow = .Cells(Rows.Count, 1).End(xlUp).Row '查詢工作表1的最後一列位置
  60.         For Each Rng In .Range("A2", .Cells(myRow, 1)) '此迴圈做 有資料Range位置的聯集 Union
  61.             If Rng <> "" Then
  62.                 k = k + 1
  63.                 If k = 1 Then
  64.                     Set Rn = Rng
  65.                 Else
  66.                     Set Rn = Union(Rn, Rng)
  67.                 End If
  68.             End If
  69.         Next
  70.     End With
  71.     Workbooks.Open (xlPath & xlFile) '打開"每日更新接收.xlsx"活頁簿
  72.     For Each Ran In Rn
  73.         With Workbooks(xlFile).Sheets(Ran.Value)
  74.             Set ch = .Columns(1).Find(Ran.Offset(, 1), LookAt:=xlWhole, SearchDirection:=2)
  75.             '檢查日期是否有重複，當ch變數為Nothing時，則無發現重複日期，否則離開這一次的資料儲存，並執行下一個迴圈
  76.             If Not ch Is Nothing Then MsgBox Ran & "工作表中的" & ch & "資料已存在，不會儲存資料": Set ch = Nothing: GoTo 20
  77.             xlRo = .Cells(Rows.Count, 1).End(xlUp).Row + 1
  78.             For I = 1 To myCol - 1
  79.                 If I = 5 Or I = 6 Or I = 8 Or I = 9 Or I = 29 Or I = 30 Or I = 48 Or I = 49 Then GoTo 10 '不寫入函數跳過有函數的儲存格
  80.                 .Cells(xlRo, I) = Ran.Offset(, I)
  81. 10:
  82.             Next
  83.         End With
  84. 20:
  85.     Next
  86.     Workbooks(xlFile).Close True '關閉"每日更新接收.xlsx"活頁簿
  87. End Sub
複製代碼

TOP

lpk187

帖子
552 
主題
6 
精華
0 
積分
576 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2015-2-8 
最後登錄
2026-9-10 

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
7#
發表於 2015-11-11 23:59 | 顯示全部帖子
回復 16# mark761222

我以下圖來解釋 程式，更詳細的方法，你可以利用 F8逐行來執行程式，並利用區域變數數視窗來觀看程式 怎麼走的

   

TOP

lpk187

帖子
552 
主題
6 
精華
0 
積分
576 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2015-2-8 
最後登錄
2026-9-10 

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
8#
發表於 2015-11-12 22:22 | 顯示全部帖子
回復 18# mark761222


    如果 T與B跟C的 不會複製的地方不一樣 ，還有將檔案分至2個excel怎麼更改呢?
不會複製的地方，我該怎麼樣去判斷？位置？顏色？完全沒有規則！
匯出資料工作表中，有好幾個Tabl，位置會不會不同？該怎麼電腦去判別它的啟始位置？它未來的位置會和附件一樣？
再來是合併儲存格，VBA判別資料，若遇到合併儲存格，最容易出錯了。

看了你的附件，如果整合在一起，坦白說很難！
至於，要分多個檔案，或多個工作表不是難事，難的是要匯出的資料，完全沒有系統性的規劃！

TOP

lpk187

帖子
552 
主題
6 
精華
0 
積分
576 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2015-2-8 
最後登錄
2026-9-10 

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
9#
發表於 2015-11-13 09:13 | 顯示全部帖子
回復 20# mark761222


    在匯出資料在中的工作表名稱和目的的工作表名稱有誤，可能是因為空格的關係，請自行修正否則會有 aaa.png 的錯誤產生
  1. Sub 按鈕1_Click()
  2.     Application.ScreenUpdating = False
  3.     Dim d As Object
  4.     Dim xlPath As Variant, xlFile As Variant, aa As Variant
  5.     Dim Rng As Range, Rn As Range, Ran As Range, ch As Range
  6.     Dim myRow As Integer, myCol As Integer, k As Integer, I As Integer, j As Integer, xlRow As Integer
  7.     xlPath = ThisWorkbook.Path & "\"
  8.     Set d = CreateObject("scripting.dictionary") '設定d為字典物件
  9.     With Sheets("匯出資料")
  10.         For Each Rng In .Range("A3", Cells(Rows.Count, 1).End(xlUp)) '此迴圈是讀取檔案名稱
  11.             If Rng <> "" Then
  12.                 d(Rng.Value) = ""
  13.             End If
  14.         Next
  15.         myRow = .Cells(Rows.Count, 1).End(xlUp).Row '查詢"匯出資料"的最後一列位置
  16.         For Each Rng In .Range("B2", .Cells(myRow, 2)) '此迴圈做 有資料Range位置的聯集 Union，讀取工作表名稱
  17.             If Rng <> "" Then
  18.                 k = k + 1
  19.                 If k = 1 Then
  20.                     Set Rn = Rng
  21.                 Else
  22.                     Set Rn = Union(Rn, Rng)
  23.                 End If
  24.             End If
  25.         Next
  26.     End With
  27.         xlFile = d.keys '將字典的key值給予xlFile(為陣列)，以目前讀取的檔案名稱有"Daily Yield Rate report 分廠 2015BR"
  28.                         '以及"Daily Yield Rate report(EN)2015BR4"2個檔案
  29.         
  30.     For I = 0 To UBound(xlFile) '以檔案為做為迴圈，來開啟檔案
  31.         With Workbooks.Open(xlPath & xlFile(I) & ".xlsx") '開啟檔案
  32.             For Each Ran In Rn '執行工作表迴圈
  33.                 If Ran.Offset(, -1) Like xlFile(I) Then '比對此工作表是否屬於xlFile(I)檔案，如果是則執行If中程序
  34.                     With .Sheets(Ran.Value)
  35.                         Set ch = .Columns(1).Find(Ran.Offset(, 1), LookAt:=xlWhole, SearchDirection:=2)
  36.                         '檢查日期是否有重複，當ch變數為Nothing時，則無發現重複日期，否則離開這一次的資料儲存，並執行下一個迴圈
  37.                         If Not ch Is Nothing Then MsgBox Ran & "工作表中的" & ch & "資料已存在，不會儲存資料": Set ch = Nothing: GoTo 10
  38.                         myCol = ThisWorkbook.Sheets("匯出資料").Cells(Ran.Row, Columns.Count).End(xlToLeft).Column
  39.                         xlRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 '讀取目的工作表的最後一列列號
  40.                         For j = 1 To myCol - 2
  41.                             If Ran.Offset(, j).Interior.Color <> 65535 Then '當儲存格色彩不屬於黃色，則執行複製值
  42.                                 .Cells(xlRow, j) = Ran.Offset(, j).Value '複製值
  43.                             End If
  44.                         Next
  45. 10:
  46.                     End With
  47.                 End If
  48.             Next '完成一個工作表後執行下一個工作表
  49.             .Close True '關閉及儲存檔案
  50.         End With
  51.     Next
  52.     Application.ScreenUpdating = False
  53. End Sub
複製代碼

TOP

lpk187

帖子
552 
主題
6 
精華
0 
積分
576 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2015-2-8 
最後登錄
2026-9-10 

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
10#
發表於 2015-11-13 09:22 | 顯示全部帖子
回復 20# mark761222


    會產生錯誤的工作表名稱為Daily Yield Rate report 分廠 2015B檔案的"B DailyYeild (F1-By Date)"和"T Daily Yeild (F2-By Date )"

TOP

        靜思自在 : 難行能行，難捨能捨，難為能為，才能昇華自我的人格。
返回列表 上一主題