My VBA code in excel works with F8 but doesn't with F5. Here below you see my code.

Sub CheckFileExists()

'Clear content
Windows("FilesExists.xlsm").Activate
    Sheets("FilesExists").Select
    Range("C50").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("C50").Select

Windows("FilesExists.xlsm").Activate
    Sheets("FilesExists").Select
    Set ws = ThisWorkbook.Worksheets("FilesExists")
    
Dim webURL As String
Numrows = Range("B50", Range("B50").End(xlDown)).Rows.Count
Range("B50").Select

With ws
For x = 1 To Numrows
    'delay (3)
    CurrValue = ActiveCell.Value
    webURL = CurrValue
    If IsURLGood(webURL) = True Then
        .Range("C" & (ActiveCell.Row)).Value = "EXISTS"
    Else
        .Range("C" & (ActiveCell.Row)).Value = "CHECK"
    End If
    ActiveCell.Offset(1, 0).Select
    Next
End With
'Improves performance/stability
Call OptimizeCode_End

End Sub

Public Function IsURLGood(URL As String) As Boolean 'Application.Calculation = xlCalculationManual
    Dim WinHttpReq_Today As Object
    Set WinHttpReq_Today = CreateObject("Microsoft.XMLHTTP")
    
    On Error GoTo IsURLGoodError
    WinHttpReq_Today.Open "HEAD", URL
    WinHttpReq_Today.send
    If WinHttpReq_Today.Status = 200 Then
        IsURLGood = True
    Else
        IsURLGood = False
    End If
    'Application.Calculation = xlCalculationAutomatic
    Exit Function
    
IsURLGoodError:
    IsURLGood = False
    'Application.Calculation = xlCalculationAutomatic
End Function

I really hope someone can help, so I will be able to setup automatical execution forwarding a daily mail with whether files exists. Thnaks in advance ;-)

Kind regards Soren Sig Mikkelsen

CodePudding user response：

HTTP Request (GET)

Sub CheckFileExists()

Dim dT As Double: dT = Timer

    Const WORKSHEET_NAME As String = "FileExists"
    Const SOURCE_FIRST_CELL_ADDRESS As String = "B50"
    Const DESTINATION_COLUMN_STRING As String = "C"
    Const YES_STRING As String = "EXISTS"
    Const NO_STRING As String = "CHECK"
    Const PRINT_MESSAGE As Boolean = False
    Const PRINT_MESSAGE_IF_OK As Boolean = False
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code

    Dim ws As Worksheet: Set ws = wb.Worksheets(WORKSHEET_NAME)
    If ws.FilterMode Then ws.ShowAllData

    Dim srg As Range: Set srg = SetColumn(ws.Range(SOURCE_FIRST_CELL_ADDRESS))
    If srg Is Nothing Then Exit Sub

    Dim Data() As Variant: Data = GetColumn(srg)

    Dim r As Long
    Dim URL As String
    Dim UrlExists As Boolean

    For r = 1 To UBound(Data, 1)
        URL = CStr(Data(r, 1))
        If Len(URL) > 0 Then
            If IsUrlGood(URL, PRINT_MESSAGE, PRINT_MESSAGE_IF_OK) Then
                UrlExists = True
            End If
        End If
        Data(r, 1) = IIf(UrlExists, YES_STRING, NO_STRING)
        UrlExists = False
    Next r

    Dim drg As Range: Set drg = srg.EntireRow.Columns(DESTINATION_COLUMN_STRING)
    drg.Value = Data

Debug.Print "Time Passed: " & Format(Timer - dT, "0.000")

End Sub


Function IsUrlGood( _
    ByVal URL As String, _
    Optional ByVal PrintMessage As Boolean = False, _
    Optional ByVal PrintMessageIfOK As Boolean = False) _
As Boolean
    On Error GoTo ClearError
    
    Dim StatusNumber As Long
    
    With CreateObject("MSXML2.XMLHTTP.6.0") ' New MSXML2.XMLHTTP60 '
        .Open "HEAD", URL, False
        .send
        StatusNumber = .Status
    End With
    
    If StatusNumber = 200 Then
        IsUrlGood = True
        If PrintMessageIfOK Then Debug.Print URL, StatusNumber, "OK"
    Else
        If PrintMessage Then Debug.Print URL, StatusNumber
    End If

ProcExit:
    Exit Function
ClearError:
    If PrintMessage Then
        Dim ED As String: ED = Err.Description: ED = Left(ED, Len(ED) - 2)
        Debug.Print URL, ED ' remove trailing 'vbCrLf' ('- 2')
    End If
    Resume ProcExit
End Function

Function SetColumn(ByVal FirstCellRange As Range) As Range
    With FirstCellRange
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row   1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set SetColumn = .Resize(lCell.Row - .Row   1)
    End With
End Function

Function GetColumn(ByVal OneColumnRange As Range) As Variant()
    With OneColumnRange
        If .Rows.Count = 1 Then ' one cell
            Dim Data As Variant: ReDim Data(1 To 1, 1 To 1)
            Data(1, 1) = .Value: GetColumn = Data
        Else ' multiple cells
            GetColumn = .Value
        End If
    End With
End Function

CodePudding user response：

The ranges you reference in your code aren't fully qualified causing Excel to guess which sheet/workbook to perform the actions on. When you're using F8 (debug mode) to step through the code, you're likely ensuring that Excel 'guesses' you mean the active sheet you're focused on. It won't do that when you run it without interference.

I've re-written your CheckFileExists code for you (but tried to at least keep the method yours as much as possible) and ensured all ranges are qualified to the workbook - nothing is ambiguous :

Sub CheckFileExists()

'Set references/declarations
    Dim ws As Worksheet
    Dim webURL As String
    Dim Numrows As Long, x as Long
    Set ws = Workbooks("FilesExists.xlsm").Worksheets("FilesExists")
    
'Clear content
    Range(ws.Range("C50"), ws.Range("C50").End(xlDown)).ClearContents
    
'Locate list
    Numrows = ws.Range("B50", ws.Range("B50").End(xlDown)).Rows.Count

'Work down list
    With ws.Range("C50")
        For x = 1 To Numrows
            webURL = .Offset(x - 1, 0).Value
            If IsURLGood(webURL) = True Then
                .Offset(x - 1, 1).Value = "EXISTS"
            Else
                .Offset(x - 1, 1).Value = "CHECK"
            End If
        Next
    End With

    Call OptimizeCode_End

End Sub

Note: This assumes that the first webURL to test is in cell B50 (and not a header) and the result is to be written to the cell immediately to the right of each entry.