Hallo Reinhard,
ich arbeite in einem Netzwerk, dürfte aber kein Berechtigungsproblem sein, da ich ja andere Dateien auch speichern kannn und es von den Berechtigungen her keinen Unterschied gibt zwischen den Dateien, soweit ich feststellen kann.
Hier der komplette Code, der für 38 von 39 gefundenen Dateien richtig arbeitet:
Option Explicit
Dim I, anz, anz_row, anz_col, beginn, col, row, k, l As Integer
Dim bExist, bExist_Prot, bExist_Blatt, erst As Boolean
Dim Verzeichnis, Datei, Blatt, Find As String
Dim ws, NewSheet As Worksheet
Private Sub CommandButton1_Click()
'zu durchsuchendes Verzeichnis/Ordner angegeben?
If TextBox1.Value = „“ Then
MsgBox „Bitte zu durchsuchendes Verzeichnis / Ordner angeben“
Exit Sub
Else
Verzeichnis = TextBox1.Value
End If
'zu suchender Dateiname angegeben?
If TextBox2.Value = „“ Then
MsgBox „Bitte zu suchende Datei angeben“
Exit Sub
Else
Datei = TextBox2.Value
If Left(Datei, 1) = „*“ Then
Datei = Right(Datei, Len(Datei) - 1)
End If
End If
'zu suchenden Blattnamen angegeben?
If TextBox3.Value = „“ Then
MsgBox „Bitte zu suchenden Blattnamen angeben“
Exit Sub
Else
Blatt = TextBox3.Value
End If
'in aktueller Datei neues Arbeitsblatt mit Blattname anlegen (falls vorhanden, erst löschen)
For Each ws In ThisWorkbook.Worksheets
If ws.name = „Auswertung“ Then
bExist = True: Exit For
End If
Next
If bExist Then
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(„Auswertung“).UsedRange.Clear
Application.DisplayAlerts = True
Else
Set NewSheet = ThisWorkbook.Worksheets.Add
NewSheet.name = „Auswertung“
End If
'in aktueller Datei neues Arbeitsblatt für Protokoll anlegen (falls vorhanden, erst löschen)
For Each ws In ThisWorkbook.Worksheets
If ws.name = „Protokoll“ Then
bExist_Prot = True: Exit For
End If
Next
If bExist_Prot Then
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(„Protokoll“).UsedRange.Clear
Application.DisplayAlerts = True
Else
Set NewSheet = ThisWorkbook.Worksheets.Add
NewSheet.name = „Protokoll“
End If
anz = 1
erst = True
'Zeile, ab der im Blatt „Auswertung“ begonnen werden soll
beginn = 1
I = 0
k = 0
'angegebenes Verzeichnis/Ordner nach angegebenem Dateinamen durchsuchen + Suchergebnisse inkl. Pfad im Excelfile als Protokoll speichern
Call FindSub(Verzeichnis, Datei)
'gesuchte Dateien gefunden?
For l = 1 To k
If Right(ThisWorkbook.Worksheets(„Protokoll“).Cells(l, 2).Value, Len(Datei)) = Datei Then
ThisWorkbook.Worksheets(„Protokoll“).Cells(l, 3).Value = „entspricht den Suchkriterien“
Call Auslesen(ThisWorkbook.Worksheets(„Protokoll“).Cells(l, 2).Value)
Else
ThisWorkbook.Worksheets(„Protokoll“).Cells(l, 3).Value = „entspricht nicht den Suchkriterien“
End If
Next
ThisWorkbook.Worksheets(„Protokoll“).Columns(„A:smiley:“).EntireColumn.AutoFit
ThisWorkbook.Worksheets(„Auswertung“).UsedRange.EntireColumn.AutoFit
'Arbeitsblatt mit angegebener Blattnummer aktivieren bzw. Fokus setzen
ThisWorkbook.Worksheets(„Auswertung“).Activate
End Sub
Private Sub TextBox1_Change()
'zu durchsuchendes Verzeichnis/Ordner
End Sub
Private Sub TextBox2_Change()
'zu suchender Dateiname
End Sub
Private Sub TextBox3_Change()
'zu suchenden Blattnamen
End Sub
Sub FindSub(Start, Findwhat)
'auf Laufwerk des angegebenen Verzeichnisses wechseln
ChDrive (Left(Start, 3))
'in angegebenes Verzeichnis wechseln
ChDir (Start)
'Verzeichnisse suchen
Find = Dir("*.*", vbDirectory)
Do Until Find = „“
If Left(Find, 1) „.“ And (GetAttr(Find) And vbDirectory) = vbDirectory Then
'alle gefundenen Verzeichnisse (und Unterverzeichnisse) in Excelfile speichern als Protokoll
I = I + 1
ThisWorkbook.Worksheets(„Protokoll“).Cells(I, 1).Value = Start & „“ & Find
ElseIf Left(Find, 1) „.“ And (GetAttr(Find) And vbNormal) = vbNormal Then
'gefundene Dateien zwischenspeichern
k = k + 1
ThisWorkbook.Worksheets(„Protokoll“).Cells(k, 2).Value = Start & „“ & Find
End If
Find = Dir
Loop
'prüfen, ob gefundene Verzeichnisse Unterverzeichnisse haben
For l = anz To I
anz = l + 1
Call FindSub(ThisWorkbook.Worksheets(„Protokoll“).Cells(l, 1).Value, Findwhat)
Next
End Sub
Sub Auslesen(file)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'gefundene Dateien überprüfen, ob Blattname existiert
Workbooks.Open Filename:=file
MsgBox file
For Each ws In ActiveWorkbook.Worksheets
If ws.name = (Blatt) Then
bExist_Blatt = True: Exit For
End If
Next
If bExist_Blatt Then
ActiveWorkbook.Sheets((Blatt)).Select
'Blattschutz entfernen
ActiveWorkbook.Worksheets((Blatt)).Unprotect
ActiveWorkbook.SaveAs Filename:=file
'Zellschutz entfernen
ActiveWorkbook.Worksheets((Blatt)).Cells.Select
Selection.Locked = False
'Anzahl Zeilen und Spalten bestimmen
anz_row = ActiveWorkbook.Worksheets((Blatt)).UsedRange.Rows.Count
anz_col = ActiveWorkbook.Worksheets((Blatt)).Cells(10, Columns.Count).End(xlUp).Column
If erst Then
'alles übernehmen inkl. Überschrift
For row = 10 To anz_row
If ActiveWorkbook.Worksheets((Blatt)).Cells(row, 4).Value „“ Then
For col = 1 To anz_col
ThisWorkbook.Worksheets(„Auswertung“).Cells(beginn, col).Value = ActiveWorkbook.Worksheets((Blatt)).Cells(row, col).Value
Next col
beginn = beginn + 1
Else
End If
Next row
erst = False
Else
'ab zweiter Zeile Daten in neues Arbeitsblatt übernehmen
For row = 11 To anz_row
If ActiveWorkbook.Worksheets((Blatt)).Cells(row, 4).Value „“ Then
For col = 1 To anz_col
ThisWorkbook.Worksheets(„Auswertung“).Cells(beginn, col).Value = ActiveWorkbook.Worksheets((Blatt)).Cells(row, col).Value
Next col
beginn = beginn + 1
Else
End If
Next row
End If
'Zellschutz setzen
ActiveWorkbook.Worksheets((Blatt)).Cells.Select
Selection.Locked = True
'Blattschutz setzen
ActiveWorkbook.Worksheets((Blatt)).Protect
ActiveWorkbook.SaveAs Filename:=file
Else
ThisWorkbook.Worksheets(„Protokoll“).Cells(l, 4).Value = "Blatt nicht vorhanden in " & file
End If
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Ursprünglich stand statt der Anweisung „ActiveWorkbook.SaveAs Filename:=file“ nur ActiveWorkbook.Save im Quellcode. Aber als es mir dann eine Datei in nem anderen Verzeichnis mit der gerade offenen Datei überschrieben hat, dachte ich, ich probiers mal mit der SaveAs-Methode und das Resultat war eben für diese eine Datei der Laufzeitfehler. Für alle anderen funktionierts tadellos.
Also ich bin echt ratlos.
Gruß Anjs
),