麻辣家族討論版版 - Powered by Discuz! Board

Public Sub ex1()
Sheets("工作表1").UsedRange.ClearContents
Dim xlPath As Variant, xlFile As Variant
Dim arr
xlPath = ThisWorkbook.Path & "\"
xlFile = "a.xlsx"
Workbooks.Open (xlPath & xlFile)
arr = Workbooks(xlFile).Worksheets("工作表1").UsedRange
Workbooks(xlFile).Close True
Sheets("工作表1").[A1].Resize(UBound(arr), UBound(arr, 2)) = arr
End Sub
Public Sub ex2()
Sheets("工作表1").UsedRange.ClearContents
Dim xlPath As Variant, xlFile As Variant
Dim Barr, Darr, Earr
xlPath = ThisWorkbook.Path & "\"
xlFile = "a.xlsx"
Workbooks.Open (xlPath & xlFile)
With Workbooks(xlFile).Worksheets("工作表1")
Barr = .Range("B1", .Cells(65535, "B").End(xlUp))
Darr = .Range("D1", .Cells(65535, "D").End(xlUp))
Earr = .Range("E1", .Cells(65535, "E").End(xlUp))
End With
Workbooks(xlFile).Close True
With Sheets("工作表1")
.[A1].Resize(UBound(Barr)) = Barr
.[B1].Resize(UBound(Darr)) = Darr
.[C1].Resize(UBound(Earr)) = Earr
End With
End Sub

複製代碼

Private Sub Workbook_Open()
Dim xlPath As Variant, Ro As Integer
Dim xlFilea, xlFileb, arra, arrb
xlPath = ThisWorkbook.Path & "\"
xlFilea = ("B.xlsx")
xlFileb = ("C.xlsx")
arra = Sheets("工作表1").Range("A1:E1")
arrb = Sheets("工作表1").Range("A2:E2")
For i = 0 To 1
Workbooks.Open (xlPath & xlFilea)
With Workbooks(xlFilea).Worksheets("工作表1")
Ro = .Cells(65535, 1).End(xlUp).Row + 1
.Cells(Ro, 1) = arra
End With
Workbooks(xlFilea).Close True
Next
For i = 0 To 1
Workbooks.Open (xlPath & xlFileb)
With Workbooks(xlFileb).Worksheets("工作表1")
Ro = .Cells(65535, 1).End(xlUp).Row + 1
.Cells(Ro, 1) = arrb
End With
Workbooks(xlFileb).Close True
Next
End Sub

複製代碼

Private Sub Workbook_Open()
Dim xlPath As Variant, Ro As Integer
Dim xlFilea, xlFileb, arra, arrb
xlPath = ThisWorkbook.Path & "\"
xlFilea = ("B.xlsx")
xlFileb = ("C.xlsx")
arra = Sheets("工作表1").Range("A1:E1")
arrb = Sheets("工作表1").Range("A2:E2")
Workbooks.Open (xlPath & xlFilea)
With Workbooks(xlFilea).Worksheets("工作表1")
Set da = .Columns(1).Find(arra(1, 1), , , , , 2)
If Not da Is Nothing Then GoTo 10
Ro = .Cells(65535, 1).End(xlUp).Row + 1
.Cells(Ro, 1) = arra
End With
10:
Workbooks(xlFilea).Close True
Workbooks.Open (xlPath & xlFileb)
With Workbooks(xlFileb).Worksheets("工作表1")
Set da = .Columns(1).Find(arra(1, 1), , , , , 2)
If Not da Is Nothing Then GoTo 10
Ro = .Cells(65535, 1).End(xlUp).Row + 1
.Cells(Ro, 1) = arrb
End With
20:
Workbooks(xlFileb).Close True
End Sub

複製代碼

Sub Workbook_Open2()
Dim xlPath As Variant, Ro As Integer
Dim xlFilea, xlFileb, arra, arrb
xlPath = ThisWorkbook.Path & "\"
xlFilea = ("B.xlsx")
xlFileb = ("C.xlsx")
arra = Sheets("工作表1").Range("A1:F1")
arrb = Sheets("工作表1").Range("A2:F2")
Workbooks.Open (xlPath & xlFilea)
With Workbooks(xlFilea).Worksheets("工作表1")
Set da = .Columns(1).Find(arra(1, 1), , , , , 2)
If Not da Is Nothing Then GoTo 10
Ro = .Cells(65535, 1).End(xlUp).Row + 1
.Cells(Ro, 1).Resize(UBound(arra), UBound(arra, 2)) = arra
End With
10:
Workbooks(xlFilea).Close True
Workbooks.Open (xlPath & xlFileb)
With Workbooks(xlFileb).Worksheets("工作表1")
Set da = .Columns(1).Find(arrb(1, 1), , , , , 2)
If Not da Is Nothing Then GoTo 10
Ro = .Cells(65535, 1).End(xlUp).Row + 1
.Cells(Ro, 1).Resize(UBound(arrb), UBound(arrb, 2)) = arrb
End With
20:
Workbooks(xlFileb).Close True
End Sub

複製代碼

Option Explicit
Sub Ex() '方式1為寫入函數
Dim xlPath As Variant, xlFile As Variant
Dim Rng As Range, Rn As Range, Ran As Range, ch As Range
Dim myCol As Integer, myRow As Integer, k As Integer
Dim xlRo As Integer
Dim arr
xlPath = ThisWorkbook.Path & "\" '讀取本程式檔的路徑
xlFile = "每日更新接收.xlsx" '讀取本程式檔名稱
With ThisWorkbook.Sheets("工作表1")
myCol = .Cells(1, Columns.Count).End(xlToLeft).Column '查詢工作表1的最後一欄位置
myRow = .Cells(Rows.Count, 1).End(xlUp).Row '查詢工作表1的最後一列位置
For Each Rng In .Range("A2", .Cells(myRow, 1)) '此迴圈做有資料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
Workbooks.Open (xlPath & xlFile) '打開"每日更新接收.xlsx"活頁簿
For Each Ran In Rn
With Workbooks(xlFile).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
arr = Ran.Offset(, 1).Resize(, myCol - 1)
''''把公式替換陣列中的值'''
arr(1, 5) = "=SUM(RC[5]:RC[13])"
arr(1, 6) = "=1-RC[-1]/RC[-2]"
arr(1, 8) = "=SUM(RC[12]:RC[18])"
arr(1, 9) = "=1-RC[-1]/RC[-2]"
arr(1, 29) = "=SUM(RC[5]:RC[10])"
arr(1, 30) = "=1-RC[-1]/RC[-2]"
arr(1, 48) = "=SUM(RC[2]:RC[11])"
arr(1, 49) = "=1-RC[-1]/RC[-2]"
''''
xlRo = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(xlRo, 1).Resize(, UBound(arr, 2)) = arr '寫入資料
End With
10:
Next
Workbooks(xlFile).Close True '關閉"每日更新接收.xlsx"活頁簿
End Sub
Sub Ex1() '不寫入函數跳過有函數的儲存格
Dim xlPath As Variant, xlFile As Variant
Dim Rng As Range, Rn As Range, Ran As Range, ch As Range
Dim myCol As Integer, myRow As Integer, k As Integer, I As Integer
Dim xlRo As Integer
Dim arr
xlPath = ThisWorkbook.Path & "\" '讀取本程式檔的路徑
xlFile = "每日更新接收.xlsx" '讀取本程式檔名稱
With ThisWorkbook.Sheets("工作表1")
myCol = .Cells(1, Columns.Count).End(xlToLeft).Column '查詢工作表1的最後一欄位置
myRow = .Cells(Rows.Count, 1).End(xlUp).Row '查詢工作表1的最後一列位置
For Each Rng In .Range("A2", .Cells(myRow, 1)) '此迴圈做有資料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
Workbooks.Open (xlPath & xlFile) '打開"每日更新接收.xlsx"活頁簿
For Each Ran In Rn
With Workbooks(xlFile).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 20
xlRo = .Cells(Rows.Count, 1).End(xlUp).Row + 1
For I = 1 To myCol - 1
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 '不寫入函數跳過有函數的儲存格
.Cells(xlRo, I) = Ran.Offset(, I)
10:
Next
End With
20:
Next
Workbooks(xlFile).Close True '關閉"每日更新接收.xlsx"活頁簿
End Sub

複製代碼

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

複製代碼