- 帖子
- 552
- 主題
- 3
- 精華
- 0
- 積分
- 578
- 點名
- 0
- 作業系統
- win7
- 軟體版本
- office 2010
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2015-2-8
- 最後登錄
- 2024-2-26
  
|
15#
發表於 2015-11-10 22:39
| 只看該作者
回復 14# mark761222
有2種方式，請自行測試，選擇自己的需求，一種為有函數的儲存格就寫入函數，但鑑於有可能做微調故有第二種方式，跳過有函數的儲存格- 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
|
|
