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

標題: [發問] 當某個儲存格數值>50,則立即記錄指定欄位的值(求VBA) [打印本頁]

作者: peter95 時間: 2017-2-18 00:06 標題: 當某個儲存格數值>50,則立即記錄指定欄位的值(求VBA)

首先感謝本討論區眾版主及網友們
有你們的幫助讓小弟學習到更多知識
謝謝你們

小弟有事想請問,請群上的高手幫忙
在此先感謝大家幫忙謝謝
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sheet2 的C13 是一個每秒都會變動的數

當C13>50 時
VBA 會立即自動記錄 A17:D17 這四欄的資料(ABCD的資料也是變動的值)
到sheet3
並且從sheet3的 A2開始記錄
依序往下紀錄

[attach]26654[/attach]

[attach]26655[/attach]

小弟的檔案
[attach]26656[/attach]

作者: yen956 時間: 2017-2-18 12:33

試試看!
下列VBA放到Sheet1("Sheet2")的vba中,
不要放Module1中

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, LastR As Integer, sh3 As Object
Set sh3 = Sheets("Sheet3")
Set Rng = [C13] '設定 [C13] 為 Worksheet_Change觸動範圍
LastR = sh3.[A65536].End(xlUp).Row + 1 '取得欄A最下面非空白格的下一格的列號
If Not Intersect(Target, Rng) Is Nothing And Rng.Value > 50 Then
[A17].Resize(1, 4).Select
[A17].Resize(1, 4).Copy sh3.Cells(LastR, 1)
End If
End Sub

複製代碼

作者: peter95 時間: 2017-2-18 22:56

試試看!
下列VBA放到Sheet1("Sheet2")的vba中,
不要放Module1中
yen956 發表於 2017-2-18 12:33

感謝大大
目前copy過來的是公式
而不是值

可以copy值過來嗎

感謝再感謝

作者: yen956 時間: 2017-2-19 14:37

Private Sub Worksheet_Change(ByVal Target As Range)
'假定 "C13" 的公式為 =[A1]+[B1]+[E1]
'則 Change 的 Target 為 [A1] or [B1] or [E1]
Dim Rng As Range, LastR As Integer, sh3 As Object
Set sh3 = Sheets("Sheet3")
Set Rng = Union([A1:B1], [E1])    '設定 Worksheet_Change觸動範圍(與公式有關的Range要全部放進去)
LastR = sh3.[A65536].End(xlUp).Row + 1    '取得 "Sheet3" 欄A最下面非空白格的下一格的列號
If Not Intersect(Target, Rng) Is Nothing Then
      If [C13] > 50 Then
         [A17].Resize(1, 4).Select
         [A17].Resize(1, 4).Copy sh3.Cells(LastR, 1)
      End If
End If
End Sub

作者: peter95 時間: 2017-2-19 20:05

試試看!
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, LastR As Integer, sh3 As Object
Set sh3 = Sheets("Sheet3")
Set Rng = [C13]    '設定 [C13] 為 Worksheet_Change觸動範圍
LastR = sh3.[A65536].End(xlUp).Row + 1    '取得欄A最下面非空白格的下一格的列號
If Not Intersect(Target, Rng) Is Nothing And Rng.Value > 50 Then
      [A17].Resize(1, 4).Select
      [A17].Resize(1, 4).Copy sh3.Cells(LastR, 1)
End If
End Sub
yen956 發表於 2017-2-18 12:33

~~~~~~~~~~~~~~~~~~~~~~~
感謝 yen956 大大的熱情回覆

我是想要將A17:19 複製到SHEET3

因為我執行大大VBA 後
他會將A17:19 用公式的方式 COPY 到 SHEET3 去

可以將COPY 呈現出我要的方式嗎??

再次感謝 yen956 大大熱情的幫忙
謝謝你
[attach]26684[/attach]

[attach]26685[/attach]

[attach]26686[/attach]

小弟將我的檔案附上請大大在幫我看看
[attach]26687[/attach]

作者: yen956 時間: 2017-2-20 18:25

回復 5# peter95
試試看!
將
   [A17].Resize(1, 4).Copy sh3.Cells(LastR, 1)
改成
   [A17].Resize(1, 4).Copy
      sh3.Cells(LastR, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
         :=False, Transpose:=False

或
將整個Worksheet_Change()刪除
改成
Private Sub Worksheet_Calculate()
Dim Rng As Range, LastR As Integer, sh3 As Object
Set sh3 = Sheets("Sheet3")
LastR = sh3.[A65536].End(xlUp).Row + 1    '取得 "Sheet3" 欄A最下面非空白格的下一格的列號
If [C13] > 50 Then
      [A17].Resize(1, 4).Copy
      sh3.Cells(LastR, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
         :=False, Transpose:=False
End If
End Sub
試試看!

作者: peter95 時間: 2017-2-21 17:39

本帖最後由 peter95 於 2017-2-21 17:47 編輯

回復 6# yen956

再次謝謝 yen956大大

目前測試已經可以將資料紀錄下來
請問大大
若一樣是以C13>50 為例
當C13>50 時 一樣將 A17:D17 的資料
可否用 觸發功能 發MAIL或 [attach]26697[/attach]給我呢??

非常感謝大大的幫忙
謝謝

作者: peter95 時間: 2017-2-21 21:43

回復  peter95
Private Sub Worksheet_Calculate()
Dim Rng As Range, LastR As Integer, sh3 As Object
Set sh3 = Sheets("Sheet3")
LastR = sh3.[A65536].End(xlUp).Row + 1    '取得 "Sheet3" 欄A最下面非空白格的下一格的列號
If [C13] > 50 Then
      [A17].Resize(1, 4).Copy
      sh3.Cells(LastR, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
         :=False, Transpose:=False
End If
End Sub
yen956 發表於 2017-2-20 18:25

可以將上列VBA 延後二分鐘執行嗎???

作者: yen956 時間: 2017-2-22 20:06

本帖最後由 yen956 於 2017-2-22 20:08 編輯

抱歉, E-mail 我不會, 可另發文請教其他大大,
每2分鐘則可借用 Hsieh版大的 onTime, 如下:

Worksheet_Calculate 刪除, 改用 Hsieh版大的 onTime
請放在 Module
http://forum.twbts.com/thread-19283-1-2.html
'從早上8點到下午5點每2分鐘執行 "Copy_test" 1次
Sub OnTime_test()
Dim t
For t = TimeValue("08:00:00") To TimeValue("17:00:00") Step TimeValue("00:02:00")
   Application.OnTime t, "Copy_test"
Next
End Sub

Sub Copy_TEST()
Dim LastR As Integer, sh2 As Object, sh3 As Object
Set sh2 = Sheets("Sheet2")
Set sh3 = Sheets("Sheet3")
LastR = sh3.[A65536].End(xlUp).Row + 1    '取得 "Sheet3" 欄A最下面非空白格的下一格的列號
If sh2.[C13] > 50 Then
      sh2.[A17].Resize(1, 4).Copy
      sh3.Cells(LastR, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
End If
End Sub

作者: peter95 時間: 2017-2-22 20:18

本帖最後由 peter95 於 2017-2-22 20:19 編輯

抱歉, E-mail 我不會, 可另發文請教其他大大,
每2分鐘則可借用 Hsieh版大的 onTime, 如下:

Worksheet_C ...
yen956 發表於 2017-2-22 20:06

感謝yen956大大

我的意思是當我開啟我的EXCEL檔時
延後2分鐘才去執行你下列的VBA
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Sub Worksheet_Calculate()
Dim Rng As Range, LastR As Integer, sh3 As Object
Set sh3 = Sheets("Sheet3")
LastR = sh3.[A65536].End(xlUp).Row + 1    '取得 "Sheet3" 欄A最下面非空白格的下一格的列號
If [C13] > 50 Then
      [A17].Resize(1, 4).Copy
      sh3.Cells(LastR, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
         :=False, Transpose:=False
End If
End Sub
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
而不是每2分鐘紀錄一次

作者: yen956 時間: 2017-2-22 21:03

有重新計算就會觸動 Worksheet_Calculate, 無法延後2分鐘,
故改用每2分鐘檢查一次(不是記錄一次), 事實上有差嗎?
你的意思是發現 [C13] > 50 就延後2分鐘記錄,
這跟每2分鐘檢查一次(不是記錄一次), 發現 [C13] > 50 再記錄,
有差嗎?

作者: peter95 時間: 2017-2-22 22:38

本帖最後由 peter95 於 2017-2-22 22:39 編輯

回復 11# yen956

謝謝 yen956大大熱情的幫忙
真的很感謝你

小的的意思是
當我開啟我的EXCEL檔時
你的VBA 就開始檢查 [C13]
但剛開啟EXCEL檔時
資料量是完全沒有進來的

所以 [C13] 那個儲存格會顯示 #N/A 就是沒資料
則VBA 就會顯示錯誤

不曉得有無辦法將此情形克服
~~~~~~~~~~~~~~~~~~~~~~~~~
[attach]26703[/attach]

[attach]26704[/attach]

作者: yen956 時間: 2017-2-23 09:43

本帖最後由 yen956 於 2017-2-23 09:46 編輯

回復 12# peter95
是的, 每2分鐘檢查一次和延後2分鐘記錄的確不一樣,
有可能每個檢查點都是低點,而錯過高點
替代方案:
新增暫存表 sheet4, 將 Worksheet_Calculate 的結果全部暫放暫存表 sheet4,
再每2分鐘從暫存表 sheet4 中選取 [C13] 最高值那列
複製到 Sheet3, 如何?

'放Module
'借用 Hsieh版大的 onTime, 請放在 Module
'http://forum.twbts.com/thread-19283-1-2.html
'從早上8點到下午5點每2分鐘執行 "Copy_test" 1次
Sub OnTime_test()
Dim t
For t = TimeValue("08:00:00") To TimeValue("17:00:00") Step TimeValue("00:02:00")
   Application.OnTime t, "Copy_test"
Next
End Sub

Sub Copy_TEST()
Dim LstR3 As Integer, LstR4 As Integer, sh3 As Object, sh4 As Object
Set sh3 = Sheets("Sheet3")
Set sh4 = Sheets("Sheet4")
LstR3 = sh3.[A65536].End(xlUp).Row + 1    '取得 "Sheet3" 欄A最下面非空白格的下一格的列號
LstR4 = sh4.[A65536].End(xlUp).Row          '取得 "Sheet4" 欄F最下面非空白格的列號
If sh4.[A1] = "" Then Exit Sub
'按 sh4.[F1] 降冪排序
sh4.[A1].Resize(LstR4, 6).Select
Selection.Sort _
      Key1:=sh4.[F1], Order1:=xlDescending, _
      Header:=xlNo
sh4.[A1].Resize(1, 4).Copy sh3.Cells(LstR3, 1)
'清除sheet4, 重新供 Worksheet_Calculate 暫存
sh4.Cells() = ""
End Sub

'下面同樣放 Sheet2
Private Sub Worksheet_Calculate()
Dim Rng As Range, LstR As Integer, sh4 As Object
Set sh4 = Sheets("Sheet4")
If Not Application.IsNumber([C13]) Then Exit Sub '沒資料就跳出
LstR4 = sh4.[A65536].End(xlUp).Row    '取得 "Sheet4" 欄A最下面非空白格的列號
If [C13] > 50 Then
      [A17].Resize(1, 4).Copy
      sh4.Cells(LstR4, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
         SkipBlanks:=False, Transpose:=False
      [C13].Copy                      '[C13]的值也保留到Sheet4欄F
      sh4.Cells(LstR4, 6).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
         SkipBlanks:=False, Transpose:=False
End If
End Sub

作者: peter95 時間: 2017-3-3 18:27

每2分鐘則可借用 Hsieh版大的 onTime, 如下:

Worksheet_Calculate 刪除, 改用 Hsieh版大的 onTime
請放在 Module
http://forum.twbts.com/thread-19283-1-2.html
'從早上8點到下午5點每2分鐘執行 "Copy_test" 1次
Sub OnTime_test()
Dim t
For t = TimeValue("08:00:00") To TimeValue("17:00:00") Step TimeValue("00:02:00")
   Application.OnTime t, "Copy_test"
Next
End Sub

Sub Copy_TEST()
Dim LastR As Integer, sh2 As Object, sh3 As Object
Set sh2 = Sheets("Sheet2")
Set sh3 = Sheets("Sheet3")
LastR = sh3.[A65536].End(xlUp).Row + 1    '取得 "Sheet3" 欄A最下面非空白格的下一格的列號
If sh2.[C13] > 50 Then
      sh2.[A17].Resize(1, 4).Copy
      sh3.Cells(LastR, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
End If
End Sub
yen956 發表於 2017-2-22 20:06

請問大大是放在模組嗎??

小弟有放但是沒有執行COPY
請問我可以修正哪裡
感謝

作者: tvvcding123 時間: 2018-5-15 12:56

請問各位大大，這個用於RTD程式中，好像只會隨程式資料的跳動，也沒判斷就直接COPY資料進去，請問各位大大知道什麼原因？謝謝

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)