[發問] 今日 日期 可以修改 可以輸入 今日之前 鎖定 無法修改後

mycmyc

這參考 GBKEE  大大 給我的指導  
但  無法實現
目的  只有今日 日期 可以修改 可以輸入   今日之前 鎖定 無法修改後  
目前無法判別  A:A 日期   只要有輸入  就鎖定  沒輸入就可以輸入
請幫我修改一下   謝謝
Book1.rar (17.61 KB)

下載次數: 13

2011-12-18 01:18

GBKEE

回復 1# mycmyc
有問題附檔上來會清楚些!

Module1 的程式碼

1. Public 密碼, Rng As Range
   
2. 'Public ->變數公用於此專案
   
3. Private Sub Auto_Open()       '一般 Module中 開啟檔案時會自動執行的程序
   
4.     密碼 = "1234"
   
5.     With Sheet(1)                                   '指定的工作表
   
6.         .Activate
   
7.         .Unprotect 密碼                             '取消工作表保
   
8.         .Cells.Locked = True                        '儲存格鎖定
   
9.         .Cells.FormulaHidden = True                 '儲存格隱藏
   
10.         Set Rng = .Cells(.UsedRange.Rows.Count + 1, 1)
    
11.         'Rng  設定已使用範圍第1欄最後的下一個空白儲存格
    
12.         Rng.Locked = False
    
13.         Rng.FormulaHidden = False
    
14.         .Protect 密碼                               '工作表設定保護
    
15.     End With
    
16.     Rng.Select
    
17. End Sub

複製代碼

Sheet(1)的程式碼

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Rng.Value <> Date Then
   
3.         Unprotect 密碼                             '取消工作表保
   
4.         Cells.Locked = True                        '儲存格鎖定
   
5.         Cells.FormulaHidden = True                 '儲存格隱藏
   
6.         Rng.Locked = False
   
7.         Rng.FormulaHidden = False
   
8.         Protect 密碼                               '工作表設定保護
   
9.     ElseIf Rng.Value = Date Then
   
10.         Unprotect 密碼                             '取消工作表保
    
11.     End If
    
12. End Sub

複製代碼

mycmyc

回復 2# GBKEE
謝謝版主回答
目前遇到問題是
目前無法判別  A:A 日期   大於 系統日期 那欄可以修改  其他多鎖定   請幫我修正

目的: 用A：A判斷 如果是今日 日期 或 A欄 空白   整列 可以修改 可以輸入  
             A欄 今日之前 鎖定 那欄整列   無法修改後  ，  A：A空白可以輸入
     例如  A8  值日期 是今日  那 A8整列可以修改
                A7  值日期 是今日之前 不能修改  那列鎖定
               A15  值是空白  就可以修改或新增
麻煩你

1. Public 密碼, Rng As Range
   
2. 'Public ->變數公用於此專案
   
3. Private Sub Auto_Open()       '一般 Module中 開啟檔案時會自動執行的程序
   
4.     密碼 = "1234"
   
5.     With Sheet1  [color=Red]此行我修改 Sheet1 非大大你  Sheet（1）[/color]                              '指定的工作表
   
6.         .Activate
   
7.         .Unprotect 密碼                             '取消工作表保
   
8.         .Cells.Locked = True                        '儲存格鎖定
   
9.         .Cells.FormulaHidden = True                 '儲存格隱藏
   
10.         Set Rng = .Cells(.UsedRange.Rows.Count + 1, 1)
    
11.         'Rng  設定已使用範圍第1欄最後的下一個空白儲存格
    
12.         Rng.Locked = False
    
13.         Rng.FormulaHidden = False
    
14.         .Protect 密碼                               '工作表設定保護
    
15.     End With
    
16.     Rng.Select
    
17. End Sub

複製代碼

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Rng.Value <> Date Then
   
3.         Unprotect 密碼                             '取消工作表保
   
4.         Cells.Locked = True                        '儲存格鎖定
   
5.         Cells.FormulaHidden = True                 '儲存格隱藏
   
6.         Rng.Locked = False
   
7.         Rng.FormulaHidden = False
   
8.         Protect 密碼                               '工作表設定保護
   
9.     ElseIf Rng.Value = Date Then
   
10.         Unprotect 密碼                             '取消工作表保
    
11.     End If
    
12. End Sub

複製代碼

Book1.rar (17.35 KB)

下載次數: 4

2011-12-18 18:29

mycmyc

GBKEE版主
如果用IF 小於  系統日期  就鎖定 整列
            IF＝空白 或等於系統日期  就不鎖定  可以達成嗎

GBKEE

回復 4# mycmyc

1. Private Sub Auto_Open()       '一般 Module中 開啟檔案時會自動執行的程序
   
2.     Dim E As Range, 密碼 As String
   
3.     密碼 = "1234"
   
4.     With Sheet1                                 '指定的工作表
   
5.         .Unprotect 密碼                             '取消工作表保
   
6.         .Cells.Locked = False                        '取消儲存格鎖定
   
7.         .Cells.FormulaHidden = False                 '取消儲存格隱藏
   
8.         For Each E In .UsedRange.Columns(1).Cells
   
9.             If IsDate(E) And E < Date Then E.EntireRow.Locked = True
   
10.         Next
    
11.         .Protect 密碼                               '工作表設定保護
    
12.     End With
    
13. End Sub

複製代碼

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Not Application.Intersect(Target, UsedRange.Columns(1)) Is Nothing Then Run "Module1.Auto_Open"
   
3. End Sub

複製代碼

mycmyc

回復 5# GBKEE


GBKEE版主
小於  系統日期  就鎖定 整列 與 空白 或等於系統日期  就不鎖定  可以達成
OK
但大於  系統日期 無法 鎖定
可以增加  如果   大於  系統日期   出現  錯誤 警告
不給輸入  回到空白值嗎？
謝謝你  麻煩你了

Hsieh

回復 6# mycmyc

下載 (301.88 KB)

2011-12-18 22:49

mycmyc

回復 7# Hsieh
感謝    Hsieh 版主
這方便 又不用開啟 巨集   謝謝 簡單好用

也 感謝 GBKEE 讓我認識一些 VBA
以下 是我 在 其他網頁找到  VBA 但不能用  
我想找 無法 簡單就破解       保護 工作表

程式如下 可以修正 使用嗎

    'excel vba工程密?加密和破解
'0>注意保?版?，?供??使用。
  
'1>一段极好的VBA保?密?破解程序??WIN98+OFFICE97破解率100%
  
'2>用以下代??VBA加密保?后用offkey 6.5-7.0及Advanced VBA pASSWORD Recovery??版均?法破解出保?程式?的密?
  
'移除VBA??保?
  
Sub MoveProtect()
  
Dim FileName As String
  
FileName = Application.GetOpenFilename("Excel文件（*.xls & *.xla）,*.xls;*.xla", , "VBA破解")
  
If FileName = CStr(False) Then
  
     Exit Sub
  
Else
  
     VBAPassword FileName, False
  
End If
  
End Sub
  
'?置VBA??保?
  
Sub SetProtect()
  
Dim FileName As String
  
FileName = Application.GetOpenFilename("Excel文件（*.xls & *.xla）,*.xls;*.xla", , "VBA破解")
  
If FileName = CStr(False) Then
  
     Exit Sub
  
Else
  
     VBAPassword FileName, True
  
End If
  
End Sub
  
Private Function VBAPassword(FileName As String, Optional Protect As Boolean = False)
  
    If Dir(FileName) = "" Then
  
       Exit Function
  
    Else
  
       FileCopy FileName, FileName & ".bak"
  
    End If
  
    Dim GetData As String * 5
  
    Open FileName For Binary As #1
  
    Dim CMGs As Long
  
    Dim DPBo As Long
  
    For i = 1 To LOF(1)
  
        Get #1, i, GetData
  
        If GetData = "CMG=""" Then CMGs = i
  
        If GetData = "[Host" Then DPBo = i - 2: Exit For
  
    Next
  
      
  
    If CMGs = 0 Then
  
       MsgBox "?先?VBA???置一?保?密?...", 32, "提示"
  
       Exit Function
  
    End If
  
      
  
    If Protect = False Then
  
       Dim St As String * 2
  
       Dim s20 As String * 1
  
         
  
       '取得一?0D0A十六?制字串
  
       Get #1, CMGs - 2, St
  
      
  
       '取得一?20十六制字串
  
       Get #1, DPBo + 16, s20
  
      
  
       '替?加密部份机?
  
       For i = CMGs To DPBo Step 2
  
           Put #1, i, St
  
       Next
  
         
  
       '加入不配?符?
  
       If (DPBo - CMGs) Mod 2 <> 0 Then
  
          Put #1, DPBo + 1, s20
  
       End If
  
       MsgBox "文件解密成功......", 32, "提示"
  
    Else
  
       Dim MMs As String * 5
  
       MMs = "DPB="""
  
       Put #1, CMGs, MMs
  
       MsgBox "?文件特殊加密成功......", 32, "提示"
  
    End If
  
    Close #1
  
End Function