结合两个VBA代码

时间:2017-08-30 04:25:26

标签: excel excel-vba vba

你能帮我把这两个代码加在一起吗?我需要将它们放在Workbook模块中,但我一直在调试"编译错误:当前范围内的重复声明"用线",ws As String" (在第二个代码中)和子工作簿打开()以黄色突出显示。

第一个代码是:

Private Sub Workbook_Open()   
Dim sh As Integer, c As Integer
Dim rng As Range
Dim UsersName As String, ws As String
Dim m As Variant
Dim wsUsers As Worksheet

'hide all but first sheet
For sh = 2 To Worksheets.Count
    Worksheets(sh).Visible = xlSheetVeryHidden
Next sh

Set wsUsers = Worksheets("Users")
Set rng = wsUsers.Range(wsUsers.Range("A1"), wsUsers.Range("A" & 
wsUsers.Rows.Count).End(xlUp))

UsersName = Environ("USERNAME")

m = Application.Match(UsersName, rng, False)

On Error GoTo myerror
If Not IsError(m) Then
    If CBool(wsUsers.Cells(Val(m), 2).Value) Then
    'admin user
    For sh = 2 To Worksheets.Count
        Worksheets(sh).Visible = xlSheetVisible
    Next sh

    Else
    'show users sheet(s)
    c = 3
    Do
        ws = CStr(wsUsers.Cells(Val(m), c).Text)
        If Len(ws) = 0 Then Exit Do
        Worksheets(ws).Visible = xlSheetVisible
        c = c + 1
    Loop

    End If

Else

    MsgBox "You Do Not Have Authorised Access To This Workbook.", 16, "No 
Access"

End If

myerror:
If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub 

第二个代码是:

Option Explicit

Public sTxtBoxPassw As String

Private Const ADMIN_PASSWORD As String = "ADMIN" 'change passwords as 
required.
Private Const WORKSHEET_PASSWORD As String = "password"
Private bRangeEdited As Boolean
Private bAdmin As Boolean
Private WithEvents ws As Worksheet
Private WithEvents ChckBx  As MSForms.CheckBox

Private Sub Workbook_Open()
With Range("InputRange")
    Set ws = .Parent
    Set ChckBx = .Parent.CheckBox1
    ChckBx.Caption = "Adminitrator"
    ChckBx.Value = False
End With
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As 
Boolean)
Dim sMSG As String
sMSG = "saving the workbook will lock the cells in the 'InputRange' ." & 
vbLf
sMSG = sMSG & "Do you want to go ahead ?"
If Not bRangeEdited Or bAdmin Then GoTo Xit
If Not ReadOnly Then
    With Range("InputRange")
        If MsgBox(sMSG, vbExclamation + vbYesNo) = vbNo Then
            Cancel = True
            GoTo Xit
        End If
        .Parent.Unprotect WORKSHEET_PASSWORD
        If .SpecialCells(xlCellTypeBlanks).Address <> .Address Then
            .SpecialCells(xlCellTypeConstants).Locked = True
            bRangeEdited = False
        End If
        .Parent.Protect WORKSHEET_PASSWORD
    End With
End If
Xit:
End Sub

Private Sub ws_Change(ByVal Target As Range)
If Not Intersect(Range("InputRange"), Target) Is Nothing Then
    bRangeEdited = True
End If
End Sub

Private Sub ChckBx_Change()
With ChckBx
    Select Case .Value
        Case True
            If EnterAdminPassword = UCase(ADMIN_PASSWORD) Then
                bAdmin = True
                Range("InputRange").Parent.Unprotect WORKSHEET_PASSWORD
            Else
                ChckBx.Value = False
                MsgBox "Wrong Adim Password", vbCritical
            End If
        Case Else
            bAdmin = False
            Range("InputRange").Parent.Protect WORKSHEET_PASSWORD
    End Select
End With
End Sub

Private Function EnterAdminPassword() As String
UserForm1.Show vbModal
EnterAdminPassword = UCase(sTxtBoxPassw)
End Function

非常感谢任何帮助。我遇到了这个article,但我对VBA不是很了解,所以我无法理解它

@SvenRasmussen:这是我的最终组合。然而,它在Set ChckBx = .Parent.CheckBox1行进行调试。

Option Explicit

Public sTxtBoxPassw As String

Private Const ADMIN_PASSWORD As String = "ADMIN" 'change passwords as 
required.
Private Const WORKSHEET_PASSWORD As String = "password"
Private bRangeEdited As Boolean
Private bAdmin As Boolean
Private WithEvents ws As Worksheet
Private WithEvents ChckBx  As MSForms.CheckBox
Private Sub Workbook_Open()
With Range("InputRange")
    Set ws = .Parent
    Set ChckBx = .Parent.CheckBox1
    ChckBx.Caption = "Administrator"
    ChckBx.Value = False
End With


Dim sh As Integer, c As Integer
Dim rng As Range
Dim UsersName As String, differentString As String
Dim m As Variant
Dim wsUsers As Worksheet


'hide all but first sheet
For sh = 2 To Worksheets.Count
    Worksheets(sh).Visible = xlSheetVeryHidden
Next sh

Set wsUsers = Worksheets("Users")
Set rng = wsUsers.Range(wsUsers.Range("A1"), wsUsers.Range("A" & 
wsUsers.Rows.Count).End(xlUp))

UsersName = Environ("USERNAME")

m = Application.Match(UsersName, rng, False)

On Error GoTo myerror
If Not IsError(m) Then
    If CBool(wsUsers.Cells(Val(m), 2).Value) Then
    'admin user
    For sh = 2 To Worksheets.Count
        Worksheets(sh).Visible = xlSheetVisible
    Next sh

    Else
    'show users sheet(s)
    c = 3
    Do
        differentString = CStr(wsUsers.Cells(Val(m), c).Text)
        If Len(differentString) = 0 Then Exit Do
        Worksheets(differentString).Visible = xlSheetVisible
        c = c + 1
    Loop

    End If

Else

    MsgBox "You Do Not Have Authorised Access To This Workbook.", 16, "No 
Access"

End If

myerror:
If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As 
Boolean)
Dim sMSG As String
sMSG = "saving the workbook will lock the cells in the 'InputRange' ." & 
vbLf
sMSG = sMSG & "Do you want to go ahead ?"
If Not bRangeEdited Or bAdmin Then GoTo Xit
If Not ReadOnly Then
    With Range("InputRange")
        If MsgBox(sMSG, vbExclamation + vbYesNo) = vbNo Then
            Cancel = True
            GoTo Xit
        End If
        .Parent.Unprotect WORKSHEET_PASSWORD
        If .SpecialCells(xlCellTypeBlanks).Address <> .Address Then
            .SpecialCells(xlCellTypeConstants).Locked = True
            bRangeEdited = False
        End If
        .Parent.Protect WORKSHEET_PASSWORD
    End With
End If
Xit:
End Sub

Private Sub ws_Change(ByVal Target As Range)
If Not Intersect(Range("InputRange"), Target) Is Nothing Then
    bRangeEdited = True
End If
End Sub

Private Sub ChckBx_Change()
With ChckBx
    Select Case .Value
        Case True
            If EnterAdminPassword = UCase(ADMIN_PASSWORD) Then
                bAdmin = True
                Range("InputRange").Parent.Unprotect WORKSHEET_PASSWORD
            Else
                ChckBx.Value = False
                MsgBox "Wrong Adim Password", vbCritical
            End If
        Case Else
            bAdmin = False
            Range("InputRange").Parent.Protect WORKSHEET_PASSWORD
    End Select
End With
End Sub

Private Function EnterAdminPassword() As String
UserForm1.Show vbModal
EnterAdminPassword = UCase(sTxtBoxPassw)
End Function

0 个答案:

没有答案