need help to alter code

R

rich_cirillo

Board Regular
Joined
Sep 26, 2012
Messages
247
Workbook contains 2 sheets...when the workbook closes down it protects the worksheets.Can the following code be altered so that it can still transfer the data from WEEKLY_DATA sheet even when the SCORE sheet is protected.The code transfers the data perfectly if the SCORE sheet is unprotected but gives error if the SCORE Sheet is protected

Thanks

Code: 
Option Explicit

Dim nmFlag  As Name
    
Sub insert_data()
    
    Dim d, i As Long, k, q, x, r As Long, Rng1 As Range
    Dim c As Long, lRow As Long, Rng2 As Range, Hdr
    
    lRow = Sheets("SCORE").Range("c" & Sheets("SCORE").Rows.Count).End(3).Row
    Set Rng2 = Sheets("SCORE").Range("c3:n" & lRow)
    d = Rng2.Value2
    q = Application.Index(d, 0, 1)
    
    Set Rng1 = Sheets("WEEKLY_GRAPH").Range("B32:m37")
    Hdr = Sheets("WEEKLY_GRAPH").Range("C21:m21")
    If Application.WorksheetFunction.CountA(Rng1) = Rng1.Cells.Count Then
        k = Rng1.Value2
        
        x = Application.Match(k(1, 1), q, 0)
        If Not IsError(x) Then
            If Len(d(x, 2)) * Len(d(x, 3)) Then 'check 2 columns whether they have data in those cells
                MsgBox "It seems data already been entered for date " & CDate(k(1, 1))
                Exit Sub
            Else
                For r = 1 To UBound(k, 1)
                    For c = 1 To UBound(k, 2)
                        d(r + x - 1, c) = k(r, c)
                    Next
                Next
                For c = 2 To UBound(d, 2): d(x - 1, c) = Hdr(1, c - 1): Next
            End If
        Else
            Set Rng2 = Sheets("SCORE").Range("c3:m" & lRow + 9)
            d = Rng2.Value2
            For r = 1 To UBound(k, 1)
                For c = 1 To UBound(k, 2)
                    d(UBound(d, 1) - UBound(k, 1) + r, c) = k(r, c)
                Next
            Next
            For c = 2 To UBound(d, 2): d(UBound(d, 1) - UBound(k, 1), c) = Hdr(1, c - 1): Next
        End If
        Rng2 = d
        Rng2.Columns(1).NumberFormat = "m/d/yyyy"
        With Rng2.Resize(Rng2.Rows.Count + 2, Rng2.Columns.Count)
            .Rows.RowHeight = 30
        End With
        On Error Resume Next
        Set nmFlag = ThisWorkbook.Names("Flag")
        On Error GoTo 0
        If nmFlag Is Nothing Then
            ThisWorkbook.Names.Add "Flag", "TRUE", 1
        Else
            nmFlag.RefersTo = "TRUE"
        End If
        'transfer code ends here. So put the msgbox here.
        MsgBox "Data has been Transferred to Score sheet", vbInformation
    Else
        MsgBox "Cannot transfer until all data entered", vbCritical
    End If
           
End Sub

Protection Code in WEEKLY_DATA Sheet
Code: 
Private Sub CommandButton1_Click()

    Dim strPassword As String
    Const strActualPassword As String = "ABCD"
    strPassword = InputBox("Please enter the password", "Protect/Unprotect Sheet")
    
    If strActualPassword = strPassword Then
        If Me.CommandButton1.Caption = "PROTECT SHEET" Then
            Me.CommandButton1.Caption = "UNPROTECT SHEET"
            UnlockCells
            Me.Protect Password:=strPassword
        Else
            Me.CommandButton1.Caption = "PROTECT SHEET"
            Me.Unprotect Password:=strPassword
        End If
    Else
        MsgBox "Invalid Password"
    End If
    
End Sub

Sub UnlockCells()

    Me.Range("C21:L21,C32:M36").Locked = False
    
End Sub

Workbook Protection in ThisWorkBook
Code: 
Private Sub Workbook_BeforeClose(Cancel As Boolean)

    Dim wks As Worksheet
    
    For Each wks In ThisWorkbook.Worksheets
        wks.Protect "ABCD"
    Next wks
    If Not Cancel Then
        Me.Save
    End If
    
End Sub
 
Sort by date Sort by votes
Thanks

This what I have below
Not sure where to place in the first code
Code: 
Private Sub CommandButton1_Click()

    Dim strPassword As String
    Const strActualPassword As String = "ABCD"
    strPassword = InputBox("Please enter the password", "Protect/Unprotect Sheet")
    
    If strActualPassword = strPassword Then
        If Me.CommandButton1.Caption = "PROTECT SHEET" Then
            Me.CommandButton1.Caption = "UNPROTECT SHEET"
            UnlockCells
            Me.Protect Password:=strPassword
        Else
            Me.CommandButton1.Caption = "PROTECT SHEET"
            Me.Unprotect Password:=strPassword
        End If
    Else
        MsgBox "Invalid Password"
    End If
    
End Sub

Sub UnlockCells()

    Me.Range("C21:L21,C32:M36").Locked = False
    
End Sub

Code: 
Private Sub Workbook_BeforeClose(Cancel As Boolean)

    Dim wks As Worksheet
    
    For Each wks In ThisWorkbook.Worksheets
        Call wks.Protect(Password:="ABCD", UserInterfaceOnly:=True)
    Next wks
    If Not Cancel Then
        Me.Save
    End If
    
End Sub
 
Upvote 0

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
try;
Rich (BB code): 
Private Sub CommandButton1_Click()


    Dim strPassword As String
    Const strActualPassword As String = "ABCD"
    strPassword = InputBox("Please enter the password", "Protect/Unprotect Sheet")
    
    If strActualPassword = strPassword Then
        If Me.CommandButton1.Caption = "PROTECT SHEET" Then
            Me.CommandButton1.Caption = "UNPROTECT SHEET"
            UnlockCells
            Call Me.Protect(Password:=strPassword, UserInterfaceOnly:=True)
        Else
            Me.CommandButton1.Caption = "PROTECT SHEET"
            Me.Unprotect Password:=strPassword
        End If
    Else
        MsgBox "Invalid Password"
    End If
    
End Sub


Sub UnlockCells()


    Me.Range("C21:L21,C32:M36").Locked = False
    
End Sub
 
Upvote 0
Tried the code but still gives error. Only works if I unprotect SCORE sheet.....gives this error - Runtime Error 1004 - Application Defined or Object Defined error

The line in the code is in Yellow from error - Rng2 = d

Code: 
Option Explicit

Dim nmFlag  As Name
    
Sub insert_data()
    
    Dim d, i As Long, k, q, x, r As Long, Rng1 As Range
    Dim c As Long, lRow As Long, Rng2 As Range, Hdr
    
    lRow = Sheets("SCORE").Range("c" & Sheets("SCORE").Rows.Count).End(3).Row
    Set Rng2 = Sheets("SCORE").Range("c3:n" & lRow)
    d = Rng2.Value2
    q = Application.Index(d, 0, 1)
    
    Set Rng1 = Sheets("WEEKLY_GRAPH").Range("B32:m37")
    Hdr = Sheets("WEEKLY_GRAPH").Range("C21:m21")
    If Application.WorksheetFunction.CountA(Rng1) = Rng1.Cells.Count Then
        k = Rng1.Value2
        
        x = Application.Match(k(1, 1), q, 0)
        If Not IsError(x) Then
            If Len(d(x, 2)) * Len(d(x, 3)) Then 'check 2 columns whether they have data in those cells
                MsgBox "It seems data already been entered for date " & CDate(k(1, 1))
                Exit Sub
            Else
                For r = 1 To UBound(k, 1)
                    For c = 1 To UBound(k, 2)
                        d(r + x - 1, c) = k(r, c)
                    Next
                Next
                For c = 2 To UBound(d, 2): d(x - 1, c) = Hdr(1, c - 1): Next
            End If
        Else
            Set Rng2 = Sheets("SCORE").Range("c3:m" & lRow + 9)
            d = Rng2.Value2
            For r = 1 To UBound(k, 1)
                For c = 1 To UBound(k, 2)
                    d(UBound(d, 1) - UBound(k, 1) + r, c) = k(r, c)
                Next
            Next
            For c = 2 To UBound(d, 2): d(UBound(d, 1) - UBound(k, 1), c) = Hdr(1, c - 1): Next
        End If
        Rng2 = d
        Rng2.Columns(1).NumberFormat = "m/d/yyyy"
        With Rng2.Resize(Rng2.Rows.Count + 2, Rng2.Columns.Count)
            .Rows.RowHeight = 30
        End With
        On Error Resume Next
        Set nmFlag = ThisWorkbook.Names("Flag")
        On Error GoTo 0
        If nmFlag Is Nothing Then
            ThisWorkbook.Names.Add "Flag", "TRUE", 1
        Else
            nmFlag.RefersTo = "TRUE"
        End If
        'transfer code ends here. So put the msgbox here.
        MsgBox "Data has been Transferred to Score sheet", vbInformation
    Else
        MsgBox "Cannot transfer until all data entered", vbCritical
    End If
           
End Sub

Thanks

Rich
 
Upvote 0
You must log in or register to reply here.

Similar threads

JeffGrant
  • Question Question
Find & Replace is searching whole workbook instead of just the sheet
Replies
7
Views
674
bobsan42
bobsan42
A
  • Solved
doesn't show data in listbox on form without any error in this code
Replies
6
Views
103
Abdo
A
Y
  • Solved
Help with VBA modification
2
Replies
10
Views
637
Burrgogi
Burrgogi
JeffGrant
  • Solved
VBA Code used twice, keeps table formatting on one sheet, but not on the other
Replies
4
Views
437
smozgur
smozgur
A
  • Solved
adapting code to merge amount for duplicates item on usrform
Replies
4
Views
299
abdo meghari
A

Forum statistics

Threads
1,223,604
Messages
6,173,312
Members
452,510
Latest member
RCan29

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top