Solved

Access Error on Range

Posted on 2011-09-15
13
824 Views
Last Modified: 2012-05-12
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
0
Comment
Question by:atljarman
  • 5
  • 5
  • 2
  • +1
13 Comments
 
LVL 61

Expert Comment

by:mbizup
ID: 36545950
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.
0
 
LVL 2

Expert Comment

by:jan24
ID: 36546085

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.

0
 
LVL 33

Expert Comment

by:Norie
ID: 36546464
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.
0
 

Author Comment

by:atljarman
ID: 36549161
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
0
 
LVL 2

Expert Comment

by:jan24
ID: 36549270
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.

0
 

Author Comment

by:atljarman
ID: 36549276
Thanks Jan24.  Look forward to your advice.
0
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 
LVL 33

Expert Comment

by:Norie
ID: 36549284
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.
0
 
LVL 33

Accepted Solution

by:
Norie earned 500 total points
ID: 36549420
Here's the whole code tested.

No errors, no ghost instances of Excel...

To be honest all you really needed was to reference things properly.
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)
        Set xlWS = xlWb.Worksheets(strWorkbookName)
    Else
        ' add new workbook with only one sheet
        Set xlWb = objApp.Workbooks.Add
    End If

    ' Prompts are enabled to prevent overwriting of existing spreadsheet
    objApp.DisplayAlerts = True


    ' Test if Worksheets exists
    If blnWorksheetExists = True Then
        MsgBox "Workbook " & strWorkbookName & " exists!" & _
               vbCrLf & vbCrLf & "Data not changed.", vbInformation + vbOKOnly, "Error"
        Exit Function
    Else
        Set 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")
            Set xlComb = xlWS.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 Worksheet, 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

PS There's probably  a few other things that could be done to tidy the code up.
0
 

Author Comment

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

0
 
LVL 33

Expert Comment

by:Norie
ID: 36551490
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.

0
 

Author Comment

by:atljarman
ID: 36551716
imnorie, thanks.  I requested closing of this question.
0
 
LVL 33

Expert Comment

by:Norie
ID: 36551948
Think you might need to award points for that.

PS Did you get the ProtectAll thing to work?
0
 

Author Closing Comment

by:atljarman
ID: 36561102
Great Job.  You may need to comment out this line:

ProtectAll xlWb

Couldn't have done it without you.
0

Featured Post

Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

Join & Write a Comment

Suggested Solutions

APEX (Application Express) is used to develop a web application from Oracle. SQL Workshop is one of the tools that comes with Oracle APEX to query or modify the database objects or to make any changes to the structure.
Never store passwords in plain text or just their hash: it seems a no-brainier, but there are still plenty of people doing that. I present the why and how on this subject, offering my own real life solution that you can implement right away, bringin…
Video by: Steve
Using examples as well as descriptions, step through each of the common simple join types, explaining differences in syntax, differences in expected outputs and showing how the queries run along with the actual outputs based upon a simple set of dem…
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

18 Experts available now in Live!

Get 1:1 Help Now