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

帖子: 522
主題: 36
精華: 1
積分: 603
點名: 0
作業系統: win xp sp3
軟體版本: Office 2003
閱讀權限: 50
性別: 男
註冊時間: 2012-12-13
最後登錄: 2021-7-11

2^#

發表於 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

複製代碼

帖子: 49
主題: 15
精華: 0
積分: 92
點名: 0
作業系統: win7
軟體版本: office2001
閱讀權限: 20
性別: 男
註冊時間: 2012-4-10
最後登錄: 2023-11-9

3^#

發表於 2017-2-18 22:56 | 只看該作者

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

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

可以copy值過來嗎

感謝再感謝

學習學習一直學習

帖子: 522
主題: 36
精華: 1
積分: 603
點名: 0
作業系統: win xp sp3
軟體版本: Office 2003
閱讀權限: 50
性別: 男
註冊時間: 2012-12-13
最後登錄: 2021-7-11

4^#

發表於 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

帖子: 49
主題: 15
精華: 0
積分: 92
點名: 0
作業系統: win7
軟體版本: office2001
閱讀權限: 20
性別: 男
註冊時間: 2012-4-10
最後登錄: 2023-11-9

5^#

發表於 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 大大熱情的幫忙
謝謝你

小弟將我的檔案附上請大大在幫我看看

Book2----.rar (8.07 KB)

學習學習一直學習

帖子: 522
主題: 36
精華: 1
積分: 603
點名: 0
作業系統: win xp sp3
軟體版本: Office 2003
閱讀權限: 50
性別: 男
註冊時間: 2012-12-13
最後登錄: 2021-7-11

6^#

發表於 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
試試看!

帖子: 49
主題: 15
精華: 0
積分: 92
點名: 0
作業系統: win7
軟體版本: office2001
閱讀權限: 20
性別: 男
註冊時間: 2012-4-10
最後登錄: 2023-11-9

7^#

發表於 2017-2-21 17:39 | 只看該作者

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

回復 6# yen956

再次謝謝 yen956大大

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

給我呢??

非常感謝大大的幫忙
謝謝

學習學習一直學習

帖子: 49
主題: 15
精華: 0
積分: 92
點名: 0
作業系統: win7
軟體版本: office2001
閱讀權限: 20
性別: 男
註冊時間: 2012-4-10
最後登錄: 2023-11-9

8^#

發表於 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 延後二分鐘執行嗎???

學習學習一直學習

帖子: 522
主題: 36
精華: 1
積分: 603
點名: 0
作業系統: win xp sp3
軟體版本: Office 2003
閱讀權限: 50
性別: 男
註冊時間: 2012-12-13
最後登錄: 2021-7-11

9^#

發表於 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

帖子: 49
主題: 15
精華: 0
積分: 92
點名: 0
作業系統: win7
軟體版本: office2001
閱讀權限: 20
性別: 男
註冊時間: 2012-4-10
最後登錄: 2023-11-9

10^#

發表於 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分鐘紀錄一次

學習學習一直學習