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

peter95

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

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

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

下載 (115.35 KB)

2017-2-18 00:05

下載 (75.44 KB)

2017-2-18 00:05

小弟的檔案
Book2.rar (7.71 KB)

下載次數: 9

2017-2-18 00:06

yen956

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

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

複製代碼

peter95

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

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

可以copy值過來嗎

感謝再感謝

yen956

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

試試看!
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 大大熱情的幫忙
謝謝你

下載 (161.38 KB)

2017-2-19 20:03

下載 (238.18 KB)

2017-2-19 20:03

下載 (205.08 KB)

2017-2-19 20:03

小弟 將我的 檔案附上 請大大 在幫我看看
Book2----.rar (8.07 KB)

下載次數: 4

2017-2-19 20:04

yen956

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

回復 6# yen956

再次謝謝 yen956大大

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

下載 (1.46 KB)

2017-2-21 17:46

給我呢??

非常感謝大大的幫忙
謝謝

peter95

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

抱歉, 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

抱歉, 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分鐘紀錄一次