asked on

Access Error on Range

Hi,

In my database, I am exporting to an excel spreadsheet. In the spreadsheet I do a variety of function including adding some dropdowns to specific cells. I am having a problem in the script below when I call the function more than one without closing the program. I've isolated the problem and created a msgbox "I've made it here first."

I think I have to activate the current worksheet, but I am not sure how to do that. Any thoughts? here is the script:

Public Function OpenExcelAddWorkbook(strFullFileName As String, _
strWorkbookName As String, _
strQueryName As String, _
Optional blnClose As Boolean) As Boolean
'Format and open Excel spreadsheet
'Creates an Excel database
'Created by Scott Walker, Accessible Data Solutions 02/8/2011
On Error GoTo Err_Proc

If Len(strFullFileName) = 0 Then
MsgBox "Missing filename.", vbCritical + vbOKOnly, "Error"
Exit Function
End If

If Len(strWorkbookName) = 0 Then
MsgBox "Missing sheet name.", vbCritical + vbOKOnly, "Error"
Exit Function
End If

If Len(strQueryName) = 0 Then
MsgBox "Missing query name or SQL string.", vbCritical + vbOKOnly, "Error"
Exit Function
End If

Dim FileNm As String
FileNm = strFullFileName

'this was added to add the fill file location in the function 8.4.11 Dwayne Jarman
strFullFileName = Forms!UpdateFirmList!strOutputFolder.value & "\" & strFullFileName & ".xls"

'MsgBox strFullFileName

'Dim MyFileExists As Boolean
Dim strTemp, varTest As String

strTemp = Dir$(strFullFileName)

If strTemp <> "" Then
'MyFileExists = True

varTest = MsgBox("Overwrite file: " & FileNm & " Sheet: " & strWorkbookName & "?" & vbCrLf & vbCrLf & _
"Note: No allows you to add additional sheets (if applies).", vbCritical + vbYesNoCancel, "Filename exists!")

If varTest = vbYes Then

SetAttr strFullFileName, vbNormal
'Then delete the file
Kill strFullFileName

ElseIf varTest = vbNo Then

' Kill Forms!UpdateFirmList!strOutputFolder.value & "\" & strFullFileName & ".xls"
Else
Exit Function
End If
End If

Dim objApp As Object
Dim intSR As Integer
Dim dbs As DAO.Database
Dim rsRecords As DAO.Recordset
Dim strMsg As String
Dim lngMaxCol As Long
Dim lngMaxRow As Long
Dim i As Long
Dim strHeading As String
Dim blnWorksheetExists As Boolean
Dim blnSpreadsheetExists As Boolean
Dim blnSummarysheetExists As Boolean

' Open database
Set dbs = CurrentDb

' Open recordset
Set rsRecords = dbs.OpenRecordset(strQueryName)

If rsRecords.EOF And rsRecords.BOF Then
MsgBox "Query or SQL returned no records.", vbCritical + vbOKOnly, "Error"
Exit Function
End If

' Open excel and add workbook
Set objApp = CreateObject("Excel.Application")
objApp.UserControl = True

' If no physical location passed, Excel will use the users working directory
' i.e. My Documents. Therefore the test for the existance of the spreadsheet
' will fail to locate it.
blnSpreadsheetExists = MyFileExists(strFullFileName)
'blnSpreadsheetExists = MyFileExists(Forms!staff!strOutputFolder.value & strFullFileName & ".xls")

If blnSpreadsheetExists Then
objApp.Workbooks.Open strFullFileName
Else
objApp.Workbooks.Add
End If

' Prompts are enabled to prevent overwriting of existing spreadsheet
objApp.DisplayAlerts = True
objApp.ActiveWorkbook.Worksheets(strWorkbookName).Activate

' Test if Worksheets exists
If blnWorksheetExists = True Then
MsgBox "Workbook " & strWorkbookName & " exists!" & _
vbCrLf & vbCrLf & "Data not changed.", vbInformation + vbOKOnly, "Error"
Exit Function
Else
objApp.ActiveWorkbook.Worksheets.Add.name = "" & strWorkbookName & ""
End If

With objApp.Worksheets("" & strWorkbookName & "")
lngMaxCol = rsRecords.Fields.Count

If rsRecords.RecordCount > 0 Then
rsRecords.MoveLast
rsRecords.MoveFirst
lngMaxRow = rsRecords.RecordCount

If lngMaxRow > 65536 Then
strMsg = Format(lngMaxRow, "#,##0") & " exceeds the maximum " & _
"of 65,536 rows that can be " & vbCrLf

If blnSpreadsheetExists Then
strMsg = strMsg & "exported directly...you will have " & _
"to manully export the " & vbCrLf & _
strMsg = strMsg & "into a spreadsheet."
MsgBox strMsg

rsRecords.Close
Set rsRecords = Nothing
Set dbs = Nothing

objApp.DisplayAlerts = False
objApp.Quit
DoCmd.OpenQuery strQueryName, acViewNormal, acReadOnly

MsgBox "Now use the File + Export manual method."
Exit Function

Else

strMsg = strMsg & "exported directly...switching to transfer."
MsgBox strMsg

rsRecords.Close
Set rsRecords = Nothing
Set dbs = Nothing

objApp.DisplayAlerts = False
objApp.Quit

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, strQueryName, strFullFileName, True

'RunExcel strFullFileName

Exit Function

End If

End If

' Let user see the data added

objApp.Visible = True
For i = 1 To lngMaxCol
.Cells(1, i).FormulaR1C1 = rsRecords.Fields(i - 1).name
.Cells(1, i).Font.Bold = True

' ColorIndex values: 0 Auto, 1 Black, 2 White, 3 Red, 5 Blue,
'6 Yellow, 10 Green, 40 Tan, 36 Light Yellow, 35 Light Green,
'34 Light Turquoise, 37 Pale Blue
.Cells(1, i).Font.ColorIndex = 1
.Cells(1, i).Interior.ColorIndex = 35
.Cells(1, i).Interior.Pattern = 1 'Excel ref variable xlSolid = 1
.Cells(1, i).Interior.PatternColorIndex = -4105 'Excel ref variable PatternColorIndex = -4105

.Cells(1, i).Borders(xlEdgeBottom).Weight = 2

Next

'findme
'Set objsht2 = .Worksheets("coop")
'objsht2.Activate

.Range(.Cells(2, 1), .Cells(lngMaxRow, lngMaxCol)).CopyFromRecordset rsRecords
'Excel ref variable xlLeft = -4131
.Range(.Cells(1, 1), .Cells(lngMaxRow + 1, lngMaxCol)).HorizontalAlignment = -4131
'.Range(.Cells(1, 1), .Cells(lngMaxRow + 1, lngMaxCol)).AutoFilter

.Range(.Cells(1, 1), .Cells(lngMaxRow + 1, lngMaxCol)).Borders.Weight = 1
.Range(.Cells(1, 1), .Cells(1, 3)).Borders(xlEdgeBottom).Weight = 2
.Range(.Cells(2, 1), .Cells(lngMaxRow + 1, 1)).Borders(xlEdgeRight).Weight = 2

.Range(.Cells(1, 1), .Cells(lngMaxRow + 1, lngMaxCol)).EntireColumn.AutoFit

.Range("C2").value = .Range("B2").value

'.Range(.Cells(2, 1), .Cells(2, 1)).EntireRow.Height = 0

End If

MsgBox "I made it here first"

With Range("C12:C12")
Set Comb = ActiveSheet.DropDowns.Add(.Left, .Top, .Width, .Height)
End With
With Comb
'.ListFillRange = "Yes,No"
'.LinkedCell = "$F$1"
.AddItem "Full-Time"
.AddItem "Part-Time"
End With

With Range("C40:C40")
Set Comb = ActiveSheet.DropDowns.Add(.Left, .Top, .Width, .Height)
End With
With Comb
'.ListFillRange = "Yes,No"
'.LinkedCell = "$F$1"
.AddItem "Yes"
.AddItem "No"
End With

With Range("C41:C41")
Set Comb = ActiveSheet.DropDowns.Add(.Left, .Top, .Width, .Height)
End With
With Comb
'.ListFillRange = "Yes,No"
'.LinkedCell = "$F$1"
.AddItem "Yes"
.AddItem "No"
End With

With Range("C42:C42")
Set Comb = ActiveSheet.DropDowns.Add(.Left, .Top, .Width, .Height)
End With
With Comb
'.ListFillRange = "Yes,No"
'.LinkedCell = "$F$1"
.AddItem "Yes"
.AddItem "No"
End With

With Range("C43:C43")
Set Comb = ActiveSheet.DropDowns.Add(.Left, .Top, .Width, .Height)
End With
With Comb
'.ListFillRange = "Yes,No"
'.LinkedCell = "$F$1"
.AddItem "Yes"
.AddItem "No"
End With

With Range("C44:C44")
Set Comb = ActiveSheet.DropDowns.Add(.Left, .Top, .Width, .Height)
End With
With Comb
'.ListFillRange = "Yes,No"
'.LinkedCell = "$F$1"
.AddItem "Yes"
.AddItem "No"
End With

With Range("C45:C45")
Set Comb = ActiveSheet.DropDowns.Add(.Left, .Top, .Width, .Height)
End With
With Comb
'.ListFillRange = "Yes,No"
'.LinkedCell = "$F$1"
.AddItem "Yes"
.AddItem "No"
End With

With Range("C48:C48")
Set Comb = ActiveSheet.DropDowns.Add(.Left, .Top, .Width, .Height)
End With
With Comb
'.ListFillRange = "Yes,No"
'.LinkedCell = "$F$1"
.AddItem "Yes"
.AddItem "No"
End With

With Range("C49:C49")
Set Comb = ActiveSheet.DropDowns.Add(.Left, .Top, .Width, .Height)
End With
With Comb
'.ListFillRange = "Yes,No"
'.LinkedCell = "$F$1"
.AddItem "Yes"
.AddItem "No"
End With

With Range("C50:C50")
Set Comb = ActiveSheet.DropDowns.Add(.Left, .Top, .Width, .Height)
End With
With Comb
'.ListFillRange = "Yes,No"
'.LinkedCell = "$F$1"
.AddItem "Yes"
.AddItem "No"
End With

With Range("C51:C51")
Set Comb = ActiveSheet.DropDowns.Add(.Left, .Top, .Width, .Height)
End With
With Comb
'.ListFillRange = "Yes,No"
'.LinkedCell = "$F$1"
.AddItem "Yes"
.AddItem "No"
End With

With Range("C52:C52")
Set Comb = ActiveSheet.DropDowns.Add(.Left, .Top, .Width, .Height)
End With
With Comb
'.ListFillRange = "Yes,No"
'.LinkedCell = "$F$1"
.AddItem "Yes"
.AddItem "No"
End With

.Range(.Cells(2, 1), .Cells(lngMaxRow + 1, 1)).Font.Bold = True
.Range(.Cells(2, 1), .Cells(lngMaxRow + 1, 1)).Interior.ColorIndex = 35
.Range(.Cells(2, 3), .Cells(lngMaxRow + 1, 3)).Interior.ColorIndex = 15
.Range(.Cells(2, 3), .Cells(lngMaxRow + 1, 3)).Locked = False
.Range(.Cells(2, 3), .Cells(2, 3)).Locked = True
.Range(.Cells(47, 3), .Cells(47, 3)).Locked = True

' Select all data
.Range(.Cells(1, 1), .Cells(lngMaxRow + 1, lngMaxCol)).Select

End With

rsRecords.Close
Set rsRecords = Nothing

'delete sheets 1, 2, and 3

objApp.Sheets("Sheet1").Delete
objApp.Sheets("Sheet2").Delete
objApp.Sheets("Sheet3").Delete

'Call ProtectAll

objApp.Sheets("coop").Protect Password:="MyPassword"

' Save excel spreadsheet
If blnSpreadsheetExists Then
objApp.ActiveWorkbook.save
Else
objApp.ActiveWorkbook.SaveAs strFullFileName
End If

' Reset alerts prompts
objApp.DisplayAlerts = True
Set dbs = Nothing
If blnClose Then
objApp.Quit
End If

OpenExcelAddWorkbook = True

Exit_Proc:
Exit Function

Err_Proc:

If Err.Number = 9 Then
blnWorksheetExists = False
Resume Next
Else
MsgBox Err.Number & "-" & Err.Description
Resume Exit_Proc
End If

End Function

mbizup

At the end of your function, before exiting add the following bolded line:

Exit_Proc:
SET objApp = Nothing
Exit Function

You shuld set any Excel objects to Nothing prior exiting the function. You should ensure that you do this before any other Exit Function statements as well.

jan24

To activate a workbook do:
objapp.Workbooks("workbook name").Activate
To activate a sheet, do:
objapp.Workbooks("workbook name").Sheets("sheet name").Activate
(this will activate both the workbook and the sheet in one step)

If that line of investigation or mbizup's suggestion doesn't solve the problem then I would suggest removing sections of the code and seeing whether the error still occurs. If you can end up with a minimal few lines of code that generate the error then it will be much easier to pinpoint the problem.

By the way, when you check for existance of a sheet with the name you are using you have:
objApp.ActiveWorkbook.Worksheets(strWorkbookName).Activate
It would be better to put
objApp.ActiveWorkbook.Sheets(strWorkbookName).Activate
because that way you take into account the possibility that a chart sheet with that name already exists. The Worksheets collection does not include chart sheets, but the Sheets collection does.

Norie

You shouldn't need to use Activate for any of this, as long as you reference everything properly.

In the section of code after the message box you don't have workbook/worksheet references for any of the ranges you are trying to add dropdowns to.

You should use object variable to reference the workbook you open/create and the worksheet you add.

For the workbook:

Dim xlWB As Object

....
If blnSpreadsheetExists Then
Set xlWB = objApp.Workbooks.Open (strFullFileName)
Else
set xlWB = objApp.Workbooks.Add
End If

You can now use xlWB to reference the workbook in the rest of the code.

Something similar can be used for the worksheet.

Not referencing properly is probably why you get the error(s) and probably why you'll find 'ghost' instances of Excel if you look in Task Manager.

atljarman

ASKER

mbizip and jan24, your suggestions did not resolve the error. imnorie, I'm not sure how to implement your suggestion. I've cut down the database and included only the essential items. The error is in the module called formatexcelsheets.

The errors is found here:

'This is where the error is.

With Range("C12:C12")
Set Comb = ActiveSheet.DropDowns.Add(.Left, .Top, .Width, .Height)
End With
With Comb
.AddItem "Full-Time"
.AddItem "Part-Time"
End With

Again, this will work when making one spreadsheet. But if you try to make more than one spread sheet during one open instance, then the function fails. I know that I am probably not referencing correctly as imnorie suggest, but I don't know how to reference appropriately to get it to function. Thanks for your help.
test.mdb
test.xls

jan24

atljarman - thanks for attaching the files. I'm at work at the moment, but I'll have a proper look at it when I get home this evening.

atljarman

ASKER

Thanks Jan24. Look forward to your advice.

Norie

No sure how to test but this might give you some idea of how you should reference things correctly.

Option Explicit

Option Compare Database



'added 8/26/11
'objApp.ActiveWorkbook.Worksheets.Add.name = "Summary"

Public Function OpenExcelAddWorkbook(strFullFileName As String, _
                                     strWorkbookName As String, _
                                     strQueryName As String, _
                                     Optional blnClose As Boolean) As Boolean
Dim strTemp As String
Dim varTest As String

    'Format and open Excel spreadsheet
    'Creates an Excel database
    'Created by Scott Walker, Accessible Data Solutions 02/8/2011
    On Error GoTo Err_Proc

    If Len(strFullFileName) = 0 Then
        MsgBox "Missing filename.", vbCritical + vbOKOnly, "Error"
        Exit Function
    End If

    If Len(strWorkbookName) = 0 Then
        MsgBox "Missing sheet name.", vbCritical + vbOKOnly, "Error"
        Exit Function
    End If

    If Len(strQueryName) = 0 Then
        MsgBox "Missing query name or SQL string.", vbCritical + vbOKOnly, "Error"
        Exit Function
    End If


    Dim FileNm As String
    FileNm = strFullFileName

    'this was added to add the fill file location in the function 8.4.11 Dwayne Jarman
    strFullFileName = Forms!UpdateFirmList!strOutputFolder.value & "\" & strFullFileName & ".xls"

    'MsgBox strFullFileName

    'Dim MyFileExists As Boolean


    strTemp = Dir$(strFullFileName)

    If strTemp <> "" Then
        'MyFileExists = True

        varTest = MsgBox("Overwrite file: " & FileNm & " Sheet: " & strWorkbookName & "?" & vbCrLf & vbCrLf & _
                         "Note: No allows you to add additional sheets (if applies).", vbCritical + vbYesNoCancel, "Filename exists!")

        If varTest = vbYes Then

            SetAttr strFullFileName, vbNormal
            'Then delete the file
            Kill strFullFileName

        ElseIf varTest = vbNo Then

            '            Kill Forms!UpdateFirmList!strOutputFolder.value & "\" & strFullFileName & ".xls"
        Else
            Exit Function
        End If
    End If

    Dim objApp As Object
    Dim xlWS As Object
    Dim xlWb As Object
    Dim xlRng As Object
    Dim xlComb As Object
    
    Dim intSR As Long
    Dim dbs As DAO.Database
    Dim rsRecords As DAO.Recordset
    Dim strMsg As String
    Dim lngMaxCol As Long
    Dim lngMaxRow As Long
    Dim I As Long
    Dim strHeading As String
    Dim blnWorksheetExists As Boolean
    Dim blnSpreadsheetExists As Boolean
    Dim blnSummarysheetExists As Boolean


    ' Open database
    Set dbs = CurrentDb

    ' Open recordset
    Set rsRecords = dbs.OpenRecordset(strQueryName)

    If rsRecords.EOF And rsRecords.BOF Then
        MsgBox "Query or SQL returned no records.", vbCritical + vbOKOnly, "Error"
        Exit Function
    End If

    ' Open excel and add workbook
    Set objApp = CreateObject("Excel.Application")
    objApp.UserControl = True

    ' If no physical location passed, Excel will use the users working directory
    ' i.e. My Documents. Therefore the test for the existance of the spreadsheet
    ' will fail to locate it.
    blnSpreadsheetExists = MyFileExists(strFullFileName)
    'blnSpreadsheetExists = MyFileExists(Forms!staff!strOutputFolder.value & strFullFileName & ".xls")

    If blnSpreadsheetExists Then
        Set xlWb = objApp.Workbooks.Open(strFullFileName)
    Else
        Set xlWb = objApp.Workbooks.Add
    End If

    ' Prompts are enabled to prevent overwriting of existing spreadsheet
    objApp.DisplayAlerts = True
    Set xlWS = xlWb.Worksheets(strWorkbookName)

    ' Test if Worksheets exists
    If blnWorksheetExists = True Then
        MsgBox "Workbook " & strWorkbookName & " exists!" & _
               vbCrLf & vbCrLf & "Data not changed.", vbInformation + vbOKOnly, "Error"
        Exit Function
    Else
        xlWS = xlWb.Worksheets.Add
        xlWS.name = strWorkbookName

    End If


    lngMaxCol = rsRecords.Fields.Count

    If rsRecords.RecordCount > 0 Then
        rsRecords.MoveLast
        rsRecords.MoveFirst
        lngMaxRow = rsRecords.RecordCount

        If lngMaxRow > 65536 Then
            strMsg = Format(lngMaxRow, "#,##0") & " exceeds the maximum " & _
                     "of 65,536 rows that can be " & vbCrLf

            If blnSpreadsheetExists Then
                strMsg = strMsg & "exported directly...you will have " & _
                         "to manully export the " & vbCrLf & _
                         strMsg = strMsg & "into a spreadsheet."
                MsgBox strMsg



                rsRecords.Close
                Set rsRecords = Nothing
                Set dbs = Nothing

                objApp.DisplayAlerts = False
                objApp.Quit

                DoCmd.OpenQuery strQueryName, acViewNormal, acReadOnly

                MsgBox "Now use the File + Export manual method."
                Exit Function

            Else

                strMsg = strMsg & "exported directly...switching to transfer."
                MsgBox strMsg

                rsRecords.Close
                Set rsRecords = Nothing
                Set dbs = Nothing

                objApp.DisplayAlerts = False
                objApp.Quit

                DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, strQueryName, strFullFileName, True

                'RunExcel strFullFileName

                Exit Function

            End If

        End If
    End If

    ' Let user see the data added
    With xlWS
        objApp.Visible = True
        For I = 1 To lngMaxCol
            .Cells(1, I).FormulaR1C1 = rsRecords.Fields(I - 1).name
            .Cells(1, I).Font.Bold = True

            ' ColorIndex values: 0 Auto, 1 Black, 2 White, 3 Red, 5 Blue,
            '6 Yellow, 10 Green, 40 Tan, 36 Light Yellow, 35 Light Green,
            '34 Light Turquoise, 37 Pale Blue
            .Cells(1, I).Font.ColorIndex = 1
            .Cells(1, I).Interior.ColorIndex = 35
            .Cells(1, I).Interior.Pattern = 1    'Excel ref variable xlSolid = 1
            .Cells(1, I).Interior.PatternColorIndex = -4105    'Excel ref variable PatternColorIndex = -4105

            .Cells(1, I).Borders(xlEdgeBottom).Weight = 2

        Next


        'findme
        'Set objsht2 = .Worksheets("coop")
        'objsht2.Activate

        .Range(.Cells(2, 1), .Cells(lngMaxRow, lngMaxCol)).CopyFromRecordset rsRecords
        'Excel ref variable xlLeft = -4131
        .Range(.Cells(1, 1), .Cells(lngMaxRow + 1, lngMaxCol)).HorizontalAlignment = -4131
        '.Range(.Cells(1, 1), .Cells(lngMaxRow + 1, lngMaxCol)).AutoFilter



        .Range(.Cells(1, 1), .Cells(lngMaxRow + 1, lngMaxCol)).Borders.Weight = 1
        .Range(.Cells(1, 1), .Cells(1, 3)).Borders(xlEdgeBottom).Weight = 2
        .Range(.Cells(2, 1), .Cells(lngMaxRow + 1, 1)).Borders(xlEdgeRight).Weight = 2
        .Range(.Cells(1, 1), .Cells(lngMaxRow + 1, lngMaxCol)).EntireColumn.AutoFit
        .Range("C2").value = .Range("B2").value


        '.Range(.Cells(2, 1), .Cells(2, 1)).EntireRow.Height = 0





        'objApp.ActiveWorkbook.Sheets("coop").Activate


        ' MsgBox "I made it here first"


        'This is where the error is.

        With .Range("C12:C12")
            Set xlComb = .DropDowns.Add(.Left, .Top, .Width, .Height)
        End With
        With xlComb
            .AddItem "Full-Time"
            .AddItem "Part-Time"
        End With


        .Range(.Cells(2, 1), .Cells(lngMaxRow + 1, 1)).Font.Bold = True
        .Range(.Cells(2, 1), .Cells(lngMaxRow + 1, 1)).Interior.ColorIndex = 35
        .Range(.Cells(2, 3), .Cells(lngMaxRow + 1, 3)).Interior.ColorIndex = 15
        .Range(.Cells(2, 3), .Cells(lngMaxRow + 1, 3)).Locked = False
        .Range(.Cells(2, 3), .Cells(2, 3)).Locked = True
        .Range(.Cells(47, 3), .Cells(47, 3)).Locked = True


        ' Select all data
        .Range(.Cells(1, 1), .Cells(lngMaxRow + 1, lngMaxCol)).Select




    End With

    rsRecords.Close

    Set rsRecords = Nothing


    'delete sheets 1, 2, and 3

    xlWb.Sheets("Sheet1").Delete
    xlWb.Sheets("Sheet2").Delete
    xlWb.Sheets("Sheet3").Delete


    ProtectAll xlWb

    xlWb.Sheets("coop").Protect Password:="MyPassword"

    ' Save excel spreadsheet
    If blnSpreadsheetExists Then
        xlWb.Save
    Else
        xlWb.SaveAs strFullFileName
    End If



    ' Reset alerts prompts
    objApp.DisplayAlerts = True

    Set dbs = Nothing
    If blnClose Then
        objApp.Quit
    End If

    OpenExcelAddWorkbook = True

Exit_Proc:
    Set objApp = Nothing

    Exit Function

Err_Proc:

    If Err.Number = 9 Then
        blnWorksheetExists = False
        Resume Next
    Else
        MsgBox Err.Number & "-" & Err.Description
        Resume Exit_Proc
    End If

End Function


Public Function MyFileExists(pstrFile As String) As Boolean
Dim strTemp As String
    On Error Resume Next
    strTemp = Dir$(pstrFile)

    If strTemp <> "" Then
        MyFileExists = True
    End If

End Function

Function ProtectWorksheet(ws As Object, sPassword As String) As Boolean
    On Error GoTo ErrHandler
    If Not ws.ProtectContents Then
        ws.Protect sPassword, True, True, True
    End If
    ProtectWorksheet = True
    Exit Function
ErrHandler:
    ProtectWorksheet = False
End Function



Sub ProtectAll(xlWb As Object)
Dim ws As Object

    For Each ws In xlWb.Worksheets
        ws.Protect Password:="MyPassword"
    Next
    MsgBox "All sheets Protected."
    Exit Sub

End Sub

Open in new window

Actually I just found your form and table, so hopefully I can use them to test that code.

ASKER CERTIFIED SOLUTION

Norie

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

atljarman

ASKER

imnorie, I'm getting an error on line 272: ProtectAll xlWb. I commented it out and it ran like it should.

Norie

The call to ProtectAll was commented out in the original code, but I changed it to take the workbook as a parameter.

That was supposed to get it to work, and it did for me.

If you don't need it just comment out again, if you do need it can you tell us what the error message is.

PS I ran this code 20 times in a look and it was succesful each time.

atljarman

ASKER

imnorie, thanks. I requested closing of this question.

Norie

Think you might need to award points for that.

PS Did you get the ProtectAll thing to work?

atljarman

ASKER

Great Job. You may need to comment out this line:

ProtectAll xlWb

Couldn't have done it without you.