將資料寫入到其他多個EXCEL檔案 - Excel程式區

lpk187

高中生 Rank: 3 Rank: 3

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

2016猴年全勤獎章 2015羊年全勤獎章熱烈參與勳章

21^# 跳轉到 »

發表於 2015-11-13 09:13 | 只看該作者

回復 20# mark761222

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

的錯誤產生

Sub 按鈕1_Click()
Application.ScreenUpdating = False
Dim d As Object
Dim xlPath As Variant, xlFile As Variant, aa As Variant
Dim Rng As Range, Rn As Range, Ran As Range, ch As Range
Dim myRow As Integer, myCol As Integer, k As Integer, I As Integer, j As Integer, xlRow As Integer
xlPath = ThisWorkbook.Path & "\"
Set d = CreateObject("scripting.dictionary") '設定d為字典物件
With Sheets("匯出資料")
For Each Rng In .Range("A3", Cells(Rows.Count, 1).End(xlUp)) '此迴圈是讀取檔案名稱
If Rng <> "" Then
d(Rng.Value) = ""
End If
Next
myRow = .Cells(Rows.Count, 1).End(xlUp).Row '查詢"匯出資料"的最後一列位置
For Each Rng In .Range("B2", .Cells(myRow, 2)) '此迴圈做有資料Range位置的聯集 Union，讀取工作表名稱
If Rng <> "" Then
k = k + 1
If k = 1 Then
Set Rn = Rng
Else
Set Rn = Union(Rn, Rng)
End If
End If
Next
End With
xlFile = d.keys '將字典的key值給予xlFile(為陣列)，以目前讀取的檔案名稱有"Daily Yield Rate report 分廠 2015BR"
'以及"Daily Yield Rate report(EN)2015BR4"2個檔案
For I = 0 To UBound(xlFile) '以檔案為做為迴圈，來開啟檔案
With Workbooks.Open(xlPath & xlFile(I) & ".xlsx") '開啟檔案
For Each Ran In Rn '執行工作表迴圈
If Ran.Offset(, -1) Like xlFile(I) Then '比對此工作表是否屬於xlFile(I)檔案，如果是則執行If中程序
With .Sheets(Ran.Value)
Set ch = .Columns(1).Find(Ran.Offset(, 1), LookAt:=xlWhole, SearchDirection:=2)
'檢查日期是否有重複，當ch變數為Nothing時，則無發現重複日期，否則離開這一次的資料儲存，並執行下一個迴圈
If Not ch Is Nothing Then MsgBox Ran & "工作表中的" & ch & "資料已存在，不會儲存資料": Set ch = Nothing: GoTo 10
myCol = ThisWorkbook.Sheets("匯出資料").Cells(Ran.Row, Columns.Count).End(xlToLeft).Column
xlRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 '讀取目的工作表的最後一列列號
For j = 1 To myCol - 2
If Ran.Offset(, j).Interior.Color <> 65535 Then '當儲存格色彩不屬於黃色，則執行複製值
.Cells(xlRow, j) = Ran.Offset(, j).Value '複製值
End If
Next
10:
End With
End If
Next '完成一個工作表後執行下一個工作表
.Close True '關閉及儲存檔案
End With
Next
Application.ScreenUpdating = False
End Sub