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

mark761222

下載 (56.64 KB)

2015-11-5 02:34

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

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

mark761222

回復 22# lpk187


    謝謝，我已經修正問題，感謝你的幫忙，我會好好研究，增加經驗

lpk187

回復 20# mark761222


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

lpk187

回復 20# mark761222


    在匯出資料在中的工作表名稱和目的的工作表名稱有誤，可能是因為空格的關係，請自行修正否則會有

下載 (5.6 KB)

2015-11-13 09:07

的錯誤產生

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

複製代碼

mark761222

回復 19# lpk187

抱歉我可能說明的不夠詳細，我將檔案重新整理用顏色分開了
附件中有EXCEL檔案與圖片說明

黃色區塊跳開不複製過去，因為有函數不希望覆蓋
資料彙整那部分，儲存格是不會變動的，所以從那邊發出數據給各個excle的工作表，如果前面日期相同不寫入

不知道這樣夠不夠清除，如果哪裡不懂再跟我講
謝謝

圖片說明.rar (847.13 KB)

下載次數: 6

2015-11-12 23:14

檔案匯出.rar (749.76 KB)

下載次數: 4

2015-11-12 23:14

lpk187

回復 18# mark761222


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

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

mark761222

回復 17# lpk187

檔案匯出.rar (701.29 KB)

下載次數: 6

2015-11-12 18:45

如果 T與B跟C的 不會複製的地方不一樣 ，還有將檔案分至2個excel怎麼更改呢?，如附件
有三個檔案跟上一次不一樣，如果多一個excel，還有TB位子不同。
看了你的教學，我頂多只能把它分成2個工作表去跑，如果整合在一起，怎麼讓他去判別呢

lpk187

回復 16# mark761222

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

   

下載 (88.56 KB)

2015-11-11 23:59

mark761222

回復 15# lpk187


謝謝! 順利運作，但是幾乎看不懂，不知道他的邏輯怎麼去判斷取得整個資料丟到工作表1 、2 、3   程度差太多了@_@

本來想自己改完套用到另一個工作表，看來有些難度，希望等我整理完資料完，能在幫我解答，謝謝

lpk187

回復 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
    
48. 
    
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

複製代碼