Excel VBA closed file remaining in VBA Project Editor

NikolinoDE 

Here is another code fresh from the internet, untested.

Sub Analyse()
Dim arrFilenames As Variant
Dim wbkArr As Workbook
Dim wbkBasis As Workbook
Set wbkBasis = ActiveWorkbook

Selection:
    ' Zu öffnende Dateien erfragen
    arrFilenames = Application.GetOpenFilename( _
        "Excelfiles (*.xlsm), *.xlsm, All Files (*.*), *.*", 1, _
        "Select Excel files...", MultiSelect:=True)
        'Add selected files to an array field
    If VarType(arrFilenames) = vbBoolean Then
        If MsgBox("No files were selected. Do you want to exit the Makro?", vbYesNo, "Exit?") =  _
 _
vbNo Then
            GoTo Selection
        Else
            Set wbkBasis = Nothing
            Exit Sub
        End If
    End If
    
    Application.ScreenUpdating = False
    'Hide Makro activity to gain speed

    For i = 1 To UBound(arrFilenames) ' Durchläuft die Anzahl der Dateien
        'Wenn Datei noch nicht geöffnet
        'If FileOpenYet(Dir$(arrFilenames(i))) = False Then
        If FileOpenYet(Parse_Resource(arrFilenames(i))) = False Then
            'dann öffnen
            'Workbooks.Open FileName:=arrFilenames(i)
            Workbooks.Open FileName:=Parse_Resource(arrFilenames(i))
        Else
            'oder Aktivieren
            Workbooks(arrFilenames(i)).Activate
        End If
        Set wbkArr = ActiveWorkbook
        '-------------------------------------------------------
        'hier kommt dann der Code rein, der die ausgewählten Dateien
        'betrifft. Die Ursprungsdatei ist über wbkBasis ansprechbar.
        wkbbasis.Worksheets(1).Cells(i, 1) = wbkArr.Worksheets(1).Range("F32")
        wkbbasis.Worksheets(1).Cells(i, 2) = wbkArr.Name
        wbkArr.Close savechanges:=False    'Datei schließen
        Set wbkArr = Nothing
        '-------------------------------------------------------
    Next i
    Set wbkArr = Nothing
    wbkBasis.Activate
    Set wbkBasis = Nothing
    Application.ScreenUpdating = True
End Sub

Function FileOpenYet(FileName As String) As Boolean
'eine Funktion, die Prüft ob eine Datei schon geöffnet ist.
    Dim s As String
    On Error GoTo Nonexistent
    s = Workbooks(FileName).Name
    FileOpenYet = True
    Exit Function
Nonexistent:
    FileOpenYet = False
End Function


Public Function Parse_Resource(URL As String)
'Uncomment the below line to test locally without calling the function & remove argument above
'Dim URL As String
Dim SplitURL() As String
Dim i As Integer
Dim WebDAVURI As String

'Check for a double forward slash in the resource path. This will indicate a URL
If Not InStr(1, URL, "//", vbBinaryCompare) = 0 Then

    'Split the URL into an array so it can be analyzed & reused
    SplitURL = Split(URL, "/", , vbBinaryCompare)

    'URL has been found so prep the WebDAVURI string
    WebDAVURI = "\\"

    'Check if the URL is secure
    If SplitURL(0) = "https:" Then
        'The code iterates through the array excluding unneeded components of the URL
        For i = 0 To UBound(SplitURL)
            If Not SplitURL(i) = "" Then
                Select Case i
                    Case 0
                    'Do nothing because we do not need the HTTPS element
                    Case 1
                    'Do nothing because this array slot is empty
                    Case 2
                    'This should be the root URL of the site. Add @ssl to the WebDAVURI
                        WebDAVURI = WebDAVURI & SplitURL(i) & "@ssl"
                    Case Else
                        'Append URI components and build string
                        WebDAVURI = WebDAVURI & "\" & SplitURL(i)
                End Select
            End If
        Next i
    Else
    'URL is not secure
        For i = 0 To UBound(SplitURL)
            'The code iterates through the array excluding unneeded components of the URL
            If Not SplitURL(i) = "" Then
                Select Case i
                    Case 0
                        'Do nothing because we do not need the HTTPS element
                    Case 1
                        'Do nothing because this array slot is empty
                    Case 2
                    'This should be the root URL of the site. Does not require an additional  _
slash
                        WebDAVURI = WebDAVURI & SplitURL(i)
                    Case Else
                        'Append URI components and build string
                    WebDAVURI = WebDAVURI & "\" & SplitURL(i)
                End Select
            End If
        Next i
    End If
    'Set the Parse_Resource value to WebDAVURI
    Parse_Resource = WebDAVURI
Else
'There was no double forward slash so return system path as is
    Parse_Resource = URL
End If

End Function

If the code gets stuck, put the parameters in brackets so that you force the conversion from the variant to a string.

Thank you for your understanding and patience

Nikolino

I know I don't know anything (Socrates)