@Nikolino
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)
