vorhandene Schleife erweitern
23.10.2021, 01:15
Hallo excel Freunde,
ich brauche wieder mal eure Hilfe.
Wir haben umgestellt auf excel 2016 und haben jetzt Aufträge die mit xls oder xlsm enden.
Wie muss ich die Schleife erweitern damit man auch xlsm Dateien öffnen kann.
LG perostojkov
ich brauche wieder mal eure Hilfe.
Wir haben umgestellt auf excel 2016 und haben jetzt Aufträge die mit xls oder xlsm enden.
Wie muss ich die Schleife erweitern damit man auch xlsm Dateien öffnen kann.
LG perostojkov
Code:
Option Explicit
Option Base 1
Sub MB_prod_nr_oeffnen() 'A 12.06.2013
Dim strMeldung As String, strTitel As String, strAntwort As Integer
Dim Name1 As String 'Ordner- bzw Dateiname
Dim pfad1 As String '1. Teil des Pfades
Dim pfad2 As String 'kompletter Pfad
Dim datei As String 'Dateiname
Dim Home As String 'ThisWorkbook
Dim arr() As String 'Array für Ordnernamen
Dim a As Long 'Index für arr()
Dim m As Integer 'Maschinen#
Dim monat As Integer 'Monats#
Dim bExists As Boolean
Dim oWorkbook As Object
Dim jahr As Integer 'aktuelles Jahr
'********************************************************************************
' Initialisierung
'********************************************************************************
Home = ThisWorkbook.Name
datei = ActiveCell
If datei = "" Then
Exit Sub
End If
'********************************************************************************
'Schleife 1 - MaschinenEbene
'********************************************************************************
For m = 1 To 2
'die Ordner für Jahr und Monat werden in den Programmschleifen angehängt
pfad1 = "\\192.168.2.247\produktion\PSG" & m & "\Produktion\"
'********************************************************************************
' Schleife 2 - Alle Jahres-Ordnernamen auslesen, die mit 'pfad1' beginnen
'********************************************************************************
a = 0
Erase arr
Name1 = Dir(pfad1 & "*", vbDirectory) ' Ersten Ordner-Eintrag abrufen.
Do While Name1 <> "" ' Schleife beginnen.
'Aktuelles und übergeordnetes Verzeichnis ignorieren.
If Name1 <> "." And Name1 <> ".." Then
If (GetAttr(pfad1 & Name1) And vbDirectory) = vbDirectory Then 'es handelt sich um ein gewünschtes Verzeichnis
a = a + 1 'Index für arr aktualisieren
ReDim Preserve arr(1 To a) 'arr um einen Eintrag erweitern, bisherige Daten bleiben erhalten
arr(a) = Name1 'speichern nächsten gültigen Ordnernamen in arr
End If
End If
Name1 = Dir ' Nächsten Eintrag abrufen.
Loop
'*******************************************************************************
' Schleife 3 - alle Monats-Ordner nach Datei durchsuchen
'*******************************************************************************
For a = 1 To UBound(arr)
For monat = 1 To 12
pfad2 = pfad1 & arr(a) & "\" & IIf(monat < 10, "0" & monat, monat) & "\" & datei & ".xls" 'Gesamt-Pfad wenn unterordner 1-10 mit 0 anfangen
Name1 = Dir(pfad2)
If Name1 <> "" Then
'*******************************************************************************
' Prüfen ob Datei bereits geöffnet ist
'*******************************************************************************
bExists = False
With Application
For Each oWorkbook In .Workbooks
If UCase$(oWorkbook.Name) = pfad2 Then
' Jetzt aktivieren
Windows(oWorkbook.Name).Activate
bExists = True
Exit For
End If
Next
End With
' Mappe neu laden!
If Not bExists Then
On Error Resume Next
If m = 2 Then
If MsgBox("Der Auftrag wurde bei PSG" & m & " gefunden. Möchtest du den öffnen?", vbYesNo, "Bei PSG" & m & " gefunden") = vbNo Then Exit Sub
End If
If m = 1 Then
Workbooks.Open Filename:=pfad2, ReadOnly:=False
Else: Workbooks.Open Filename:=pfad2, ReadOnly:=True
End If
On Error GoTo 0
End If
Exit Sub
End If
Next monat
Next a 'nächsten Ordner verarbeiten
Next m
'*******************************************************************************
'Datei nicht gefunden, fragen ob der Monatsordner geöffnet werden soll
'*******************************************************************************
'code
End Sub
![[-]](https://www.clever-excel-forum.de/images/collapse.png)
