asked on

VBA Code Checks to See if a Sheet Exists in a Workbook and if it Does it Doesn't Always Recognize That it Exists

I have this VBA Code in MS Access that sometimes it runs properly and other times it doesn't. I'm not getting any errors, it just isn't doing what it should at times.

Here is the Code for the 3 Functions that it processes.

The issues is when it processes Lines 38-

Function ExportToExcel(bSkipFF As Boolean, Optional bIsALL As Boolean = False) As Long
'  On Error GoTo ErrHandler
  Dim strFilePath As String
  Dim xlApp As Excel.Application
  Dim xlWorkBook As Excel.Workbook
  Dim xlSheet As Excel.Worksheet
  
  strFilePath = GetWinTempPath & "FracFocusData.xlsx"
  If Dir(strFilePath) <> "" Then Kill strFilePath
  
  If bIsALL = True Then
    DoCmd.TransferSpreadsheet acExport, , "qry_FRAC_ACTIVITY_ALL", strFilePath
  Else
    DoCmd.TransferSpreadsheet acExport, , "qry_FRAC_ACTIVITY_SEL", strFilePath
    DoCmd.TransferSpreadsheet acExport, , "qry_JL_03", strFilePath
  End If
  
  Set xlApp = New Excel.Application
  Set xlWorkBook = xlApp.Workbooks.Open(strFilePath)
  xlApp.Visible = True
 
  If bIsALL = True Then
    xlApp.Worksheets("qry_FRAC_ACTIVITY_ALL").Name = "FracData"
  Else
    xlApp.Worksheets("qry_FRAC_ACTIVITY_SEL").Name = "FracData"
    xlApp.Worksheets("qry_JL_03").Name = "OnlyOnLeviRpt"
  End If
  
  xlApp.Worksheets(1).select
  ExportToExcel = MakeExcelPretty(xlApp, bSkipFF, bIsALL)
  If ExportToExcel <> 0 Then
    Set xlSheet = Nothing
    Set xlWorkBook = Nothing
    Set xlApp = Nothing
    Exit Function
  End If
  
  If WksExists("OnlyOnLeviRpt") Then
  xlApp.Worksheets("OnlyOnLeviRpt").select
    ExportToExcel = MakeExcelPretty(xlApp, bSkipFF, bIsALL)
    If ExportToExcel <> 0 Then
      Set xlSheet = Nothing
      Set xlWorkBook = Nothing
      Set xlApp = Nothing
      Exit Function
    End If
  End If
  
  xlApp.Worksheets(1).select
  
Exit Function

ErrHandler:
  Set xlSheet = Nothing
  Set xlWorkBook = Nothing
  Set xlApp = Nothing

  If err.Number = 70 Then 'user probably has it open
    MsgBox "Please Close FracFocusData.xls", vbExclamation, "Unable to Export"
    ExportToExcel = -1
    Exit Function
  End If

  ExportToExcel = ErrorHandler(err, "ExportToExcel")
End Function

Open in new window

Function WksExists(wksName As String) As Boolean

    On Error Resume Next
    WksExists = (Worksheets(wksName).Name = wksName)
  
End Function

Open in new window

Function MakeExcelPretty(xlApp As Excel.Application, bSkipFF As Boolean, Optional bIsALL As Boolean = False) As Long
  On Error GoTo ErrHandler
  Dim nLastRow As Long
  Dim nLastCol As Long
  Dim strCol As String
  Dim strRange As String
  Dim nLoop As Long
  
  'Autofit Data
  xlApp.cells.select
  xlApp.cells.EntireColumn.AutoFit
  
  'Determine data's range
  xlApp.Range("A1").select
  xlApp.selection.end(xlDown).select
  nLastRow = xlApp.ActiveCell.Row
  
  xlApp.Range("A1").select
  xlApp.selection.end(xlToRight).select
  nLastCol = xlApp.ActiveCell.Column
  
  strCol = ExcelCol_ToString(nLastCol)
  
  'Set col headers color
  xlApp.Range("A1:" & strCol & "1").select
  With xlApp.selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorDark1
    .TintAndShade = -0.249977111117893
    .PatternTintAndShade = 0
  End With
  
  'Add lines
  xlApp.Range("A1:" & strCol & nLastRow).select
  'stupid f'n ms and their transfer spreadsheet only to xls isnt lame enough, they have to have some da font set too...jfc
  With xlApp.selection.Font
      .Name = "Calibri"
      .Size = 11
      .Strikethrough = False
      .superScript = False
      .subScript = False
      .OutlineFont = False
      .Shadow = False
      .Underline = xlUnderlineStyleNone
      .ColorIndex = xlAutomatic
      .TintAndShade = 0
      .ThemeFont = xlThemeFontNone
  End With
    
  With xlApp.selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
  End With
  With xlApp.selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
  End With
  With xlApp.selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
  End With
  With xlApp.selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
  End With
  With xlApp.selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
  End With
  With xlApp.selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
  End With
  
  If xlApp.ActiveWorkbook.ActiveSheet.Name <> "OnlyOnLeviRpt" Then
  
  If bIsALL = False Then
  
  'Special - Highlight exceptions
  For nLoop = 2 To nLastRow 'skipping header row
    'no com hfr and days >= 60 then highlight yellow
    If xlApp.Range("M" & nLoop).Value = "" And xlApp.Range("P" & nLoop).Value >= 60 Then
       xlApp.Range("M" & nLoop).Interior.Color = 65535
    End If
    'no reg hfr and days >= 60 then highlight yellow
    If xlApp.Range("N" & nLoop).Value = "" And xlApp.Range("P" & nLoop).Value >= 60 Then
       xlApp.Range("N" & nLoop).Interior.Color = 65535
    End If
    
    If bSkipFF = False Then
        'not in frac focus and days between 30 and 40 then highlight yellow
      If xlApp.Range("O" & nLoop).Value <> "1" And xlApp.Range("P" & nLoop).Value >= 30 And xlApp.Range("P" & nLoop).Value <= 40 Then
        xlApp.Range("P" & nLoop).Interior.Color = 65535
        xlApp.Range("O" & nLoop).Interior.Color = 65535
      End If
      'not in frac focus and days > 60 then highlight red
      If xlApp.Range("O" & nLoop).Value <> "1" And xlApp.Range("P" & nLoop).Value > 40 Then
        xlApp.Range("P" & nLoop).Interior.Color = 255
        xlApp.Range("O" & nLoop).Interior.Color = 255
      End If
    Else
    
      'days between 30 and 40 then highlight yellow
      If xlApp.Range("P" & nLoop).Value >= 30 And xlApp.Range("P" & nLoop).Value <= 40 And xlApp.Range("N" & nLoop).Value = "" Then
        xlApp.Range("P" & nLoop).Interior.Color = 65535
      End If
      'days > 60 then highlight red
      If xlApp.Range("P" & nLoop).Value > 40 And xlApp.Range("N" & nLoop).Value = "" Then
        xlApp.Range("P" & nLoop).Interior.Color = 255
      End If
    
    End If
    

    If xlApp.Range("S" & nLoop).Value = 1 Then 'im not showing a REG_HFR_MAX date, but levi is
      xlApp.Range("N" & nLoop).Interior.Color = 13421823
    End If
    
    If xlApp.Range("S" & nLoop).Value = 2 Then 'im showing the well, but levi is not
      xlApp.Range("N" & nLoop).Interior.Color = 255
    End If
    
  Next
  
    If bSkipFF = True Then
      xlApp.Columns("M:M").select
      xlApp.selection.Delete Shift:=xlToLeft
      
      xlApp.Columns("R:R").select
      xlApp.selection.Delete Shift:=xlToLeft
    Else
      xlApp.Columns("S:S").select
      xlApp.selection.Delete Shift:=xlToLeft
    End If
  
  End If
  
  End If
   'Freeze the top row
  xlApp.ActiveWindow.SplitColumn = 0
  xlApp.ActiveWindow.SplitRow = 1
  xlApp.ActiveWindow.FreezePanes = True
  
  'increase tab ratio so we can see all sheets
  xlApp.ActiveWindow.TabRatio = 0.671
  
  'Do this Last:
'  xlApp.Range("A1").select
  xlApp.Range("A2").select
  
  Exit Function
  
ErrHandler:
  MakeExcelPretty = ErrorHandler(err, "MakeExcelPretty")
End Function

Open in new window

Rey Obrero (Capricorn1)

comment first the line On Error Resume Next

Function WksExists(wksName As String) As Boolean

' On Error Resume Next
WksExists = (Worksheets(wksName).Name = wksName)

End Function

then test your codes

gdunn59

ASKER

Rey Obrero,

Ok. I'll try that and let you know what happens.

Thanks,
gdunn59

gdunn59

ASKER

Rey Obrero,

Ok. When I commented out the line "On Error Resume Next" in the WksExists Function, I get the following error:

Run-time error '1004':

Method 'Worksheets' of object'_Global' failed

Thanks,
gdunn59

ASKER CERTIFIED SOLUTION

Rey Obrero (Capricorn1)

membership

This solution is only available to members.

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

Start Free Trial

gdunn59

ASKER

Rey,

Ok. Let me try that.

Thanks,
gdunn59

gdunn59

ASKER

Rey,

That seemed to fix the issue.

Since that is working now, after it completes the spreadsheet, there is a message box on the screen that says:

"No Data was found to import!"

For some reason the Function below is being called right after the code finishes for the tab "OnlyOnLeviRpt" in the spreadsheet.

Not sure why it is going to this Function GatherFocusPageData. Would you know why? Just trying to understand what it's doing (I didn't write this code, a former employee did).

Function GatherFocusPageData() As LongPtr
'  On Error GoTo ErrHandler
  Dim tbl As IHTMLElement
  Dim td As IHTMLElement
  Dim tr As IHTMLElement
  Dim nPageNo As LongPtr
  Dim nPageTot As LongPtr
  Dim strAPI As String, strStart As String, strEnd As String
  Dim strState As String, strCounty As String, strOperator As String
  Dim strWellName As String, strLat As String, strLong As String, strDatum As String
  Dim strSQL As String
  Dim nTemp As LongPtr
  
  Set ie = Nothing
  Set ie = New InternetExplorer
  
  Do
    Timing
  Loop Until Not ie.Busy
    
  If ElementExists("MainContent_GridView1") = False Then
'    err.Raise -666, , "No Data was found to Import!"
    MsgBox ("No Data was found to import!"), vbOKOnly
'  End If

  DoCmd.SetWarnings False
  
Else

  Set tbl = ie.Document.getElementById("MainContent_GridView1")

  nPageNo = GetCurrentPage
  nPageTot = GetTotalPages

  For Each tr In tbl.rows
    If tr.rowIndex > 1 Then
      If tr.cells.length > 7 Then

        strAPI = tr.cells(1).innerText
        strStart = tr.cells(2).innerText
        strEnd = tr.cells(3).innerText
        strState = tr.cells(4).innerText
        strCounty = tr.cells(5).innerText
        strOperator = tr.cells(6).innerText
        strWellName = tr.cells(7).innerText
'        strLat = tr.cells(8).innerText
'        strLong = tr.cells(9).innerText
'        strDatum = tr.cells(10).innerText

        strWellName = Replace(strWellName, Chr(34), "'")

        strSQL = "INSERT INTO FRAC_FOCUS_DATA (PAGE_NO, PAGE_TOT, API, JOB_START, JOB_END, STATE, COUNTY, OPERATOR, WELL_NAME) SELECT "
        ', LATITUDE, LONGITUDE, DATUM) SELECT "
        strSQL = strSQL & nPageNo & ","
        strSQL = strSQL & nPageTot & ","
        strSQL = strSQL & Chr(34) & strAPI & Chr(34) & ","
        strSQL = strSQL & "#" & strStart & "#, "
        strSQL = strSQL & "#" & strEnd & "#, "
        strSQL = strSQL & Chr(34) & strState & Chr(34) & ","
        strSQL = strSQL & Chr(34) & strCounty & Chr(34) & ","
        strSQL = strSQL & Chr(34) & strOperator & Chr(34) & ","
        strSQL = strSQL & Chr(34) & strWellName & Chr(34)
'        & ","
'        strSQL = strSQL & strLat & ","
'        strSQL = strSQL & strLong & ","
'        strSQL = strSQL & Chr(34) & strDatum & Chr(34)
'
        DoCmd.RunSQL strSQL
      End If

    End If

  Next

  End If
  
  If nTimerInt < nDefTimerInt Then nTimerInt = nDefTimerInt 'lets force to never do less than 3 secs, eh?
  
  If nPageNo = nPageTot Then 'no way to tell when user is finished anymore
    Me.cmdGatherPage.Caption = "GatherPages"
    Call SetStatus("~All Pages Gathered~" & vbCrLf & vbCrLf & "Choose more State/Counties or click [Combine and Export]")
  Else
    Call SetStatus("Page " & nPageNo & " of " & nPageTot & " Gathered (Timer Interval = " & (nTimerInt / 1000) & " seconds) Estimated time Remaining: " & ((nPageTot - nPageNo) * 25) & " seconds")
    ie.Document.getElementById("MainContent_GridView1_ButtonNext").Click
    Me.TimerInterval = nTimerInt
  End If
ErrHandler:
  DoCmd.SetWarnings True
  Set td = Nothing
  Set tr = Nothing
  Set tbl = Nothing
  If err.Number <> 0 Then
    Me.cmdGatherPage.Caption = "GatherPages"
  End If
  GatherFocusPageData = ErrorHandler(err, "GatherFocusPageData")
End Function

Private Sub cmdAddAss_Click()
  If IsNull(Me.lstAssets) Then Exit Sub
  DoCmd.SetWarnings False
  DoCmd.RunSQL "INSERT INTO ASSET_GROUPS_SEL (ASSET_GROUP) SELECT '" & Me.lstAssets & "'"
  DoCmd.SetWarnings True
  Me.lstAssetsSel.Requery
  Me.lstAssetsSel = Null
End Sub

Open in new window

Rey Obrero (Capricorn1)

I need to see all the codes, upload a copy of the db

gdunn59

ASKER

Rey,

I really can't provide a copy of the database, because it contains proprietary information.

Thanks,
gdunn59

Rey Obrero (Capricorn1)

just delete the proprietary information

gdunn59

ASKER

Ok. Thanks!