Board logo

標題: [發問] 今日 日期 可以修改 可以輸入 今日之前 鎖定 無法修改後 [打印本頁]
作者: mycmyc    時間: 2011-12-18 01:22     標題: 今日 日期 可以修改 可以輸入 今日之前 鎖定 無法修改後

本帖最後由 mycmyc 於 2011-12-18 01:23 編輯

這參考 GBKEE  大大 給我的指導  
但  無法實現
目的  只有今日 日期 可以修改 可以輸入   今日之前 鎖定 無法修改後  
目前無法判別  A:A 日期   只要有輸入  就鎖定  沒輸入就可以輸入
請幫我修改一下   謝謝
[attach]8830[/attach]
作者: GBKEE    時間: 2011-12-18 16:11

回復 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    時間: 2011-12-18 18:29

本帖最後由 mycmyc 於 2011-12-18 18:33 編輯

回復 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
複製代碼
[attach]8834[/attach]
作者: mycmyc    時間: 2011-12-18 18:46

GBKEE版主
如果用IF 小於  系統日期  就鎖定 整列
            IF＝空白 或等於系統日期  就不鎖定  可以達成嗎
作者: GBKEE    時間: 2011-12-18 18:59

回復 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    時間: 2011-12-18 19:34

回復 5# GBKEE


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

回復 6# mycmyc

[attach]8838[/attach]
作者: mycmyc    時間: 2011-12-19 00:06

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



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