Board logo

標題: [發問] VBA 編寫複製進入死循環 [打印本頁]

作者: dnadark    時間: 2015-4-27 14:54     標題: VBA 編寫複製進入死循環

本帖最後由 dnadark 於 2015-4-27 14:57 編輯

您好:

附件除A欄之外都將儲存格鎖定進行保護
唯A欄值大於或小於B欄時,會將A欄儲存格的資料複製到C欄
並鎖住A欄該儲存格,再保護工作表,
但是複製時不斷陷入死循環,請問有沒有其他的寫法可以改善?

If Cells(Target.Row, 1) <> "" And Cells(Target.Row, 1) > Cells(Target.Row, 2) * 2 Or Cells(Target.Row, 1) <> "" And Cells(Target.Row, 1) < Cells(Target.Row, 2) * 0.5 Then
ActiveSheet.Unprotect
Cells(Target.Row, 3) = Cells(Target.Row, 1)---->卡住
Cells(Target.Row, 1).Locked = True
  ActiveSheet.Protect
End If
作者: stillfish00    時間: 2015-4-27 16:37

回復 1# dnadark
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     On Error GoTo ERR_HANDLE
  3.     If Cells(Target.Row, 1) <> "" And Cells(Target.Row, 1) > Cells(Target.Row, 2) * 2 Or Cells(Target.Row, 1) <> "" And Cells(Target.Row, 1) < Cells(Target.Row, 2) * 0.5 Then
  4.         ActiveSheet.Unprotect
  5.         Application.EnableEvents = False
  6.         Cells(Target.Row, 3) = Cells(Target.Row, 1)
  7.         Cells(Target.Row, 1).Locked = True
  8.         ActiveSheet.Protect
  9.     End If
  10.    
  11. BEFORE_EXIT:
  12.     Application.EnableEvents = True
  13.     Exit Sub

  14. ERR_HANDLE:
  15.     MsgBox Err.Description, vbCritical, "ERROR:" & Err.Number
  16.     Resume BEFORE_EXIT
  17. End Sub
複製代碼

作者: dnadark    時間: 2015-4-27 17:40

您好:
        謝謝!已經試成功了,但是該巨集完了之後其實後面還有寫其他巨集,
如附件,剛剛的是當不符合時的狀況,但是符合條件時會將符合的列的資料鎖住
並將其他的列也全鎖住,只開放下一列供寫入
但是加下您所提供的資料後,後續都無效,請問要怎麼接呢?

       If Cells(Target.Row, 1) <> "" And Cells(Target.Row, 3) <> "" Then
    ActiveSheet.Unprotect
    Range(Cells(Target.Row, 1), Cells(Target.Row, 3)).Locked = True
    Range(Cells(Target.Row + 2, 1), Cells(1048576, 3)).Locked = True
    Range(Cells(Target.Row + 1, 1), Cells(Target.Row + 1, 3)).Locked = False
     ActiveSheet.Protect
    Cells(Target.Row + 1, 1).Select
    end if
作者: stillfish00    時間: 2015-4-27 19:35

回復 3# dnadark
插入在2# 程式碼的第10行看看
不然就上傳檔案
作者: dnadark    時間: 2015-4-27 20:45

您好:試過大成功!!非常謝謝您!




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