Thema: Arbeitsmappen Öffnen per Schleife | Herbers Excel-Forum

Hi Experten
Präzisierung gestriger Anfrage
Habe folgende Mappen: LS00001.xls, LS00002.xls, LS00003 usw. 2000Stück
Jede Datei beinhaltet die gleiche Struktur und gleiche Makros
Ziel: Mappen unter gleichem Namen an anderer Stelle abspeichern aber ohne Makros (Lösung von Gestern
war Makro löschen...das geht aber nicht weil Makro password geschützt...
Kann mir jemand nochmal helfen
Vielen Dank im Voraus!!

Hallo,
sind die Makros im Modul, oder befinden sich diese in den einzelnen Sheets? Fallas sie in einem Modul sind, lass doch per Makro eine neue Arbeitsmappe öffnen und kopiere die Sheets dorthin. Anschließend diese neue arbeitsmappe unter neuem Namen speichern und schließen.
Oder kopiere nur den Inhalt in die neue Arbeitsmappe.
Gruß
welga

Hallo Welga
hatte gestern ne Lösung von "Josef Ehrensberger"alias Seep zum löschen der Makros. Geht aber leider nur ohne Password. Password ist mir zwar bekannt aber ich bekomme es nicht über SendKeys ins Makro rein... (es wirkt nicht in dieser Schleife auf die zu korrigierenden Mappen die bleben immer geschützt).
Deshalb war das was Du schreibst eine weitere naheliegende Idee. Bin aber nicht in der Lage so ein Makro zu schreiben.
Also so wie es oben steht: Mappen unter gleichem Namen an anderer Stelle abspeichern und zwar nur die Inhalte und die Form von Blatt 1 und Blatt2 (ohne die Makros die übrigens in Modulen und in Blättern stehen)
Gruß
Carsten

Hallo Carsten,
ich hab mal welga's Idee in meinen Code eingebaut.

Hi.
Probier mal das... dauert aber eine Weile:

Sub kopierenOhneMakros()
Const quellPfad = "C:\temp\quelle\"
Const zielPfad = "c:\temp\ziel\"
Const dateiAnf = "LS"
Const dateiEnd = ".xls"
Const dateiNrLaenge = 5
Dim dateiNr As Long
Dim dateiNrString As String
Dim dateiName As String
Dim myWbk As Workbook
Application.ScreenUpdating = False
For dateiNr = 1 To 2000 ' Nr. anpassen, darf mehr sein
dateiNrString = dateiNr
While Len(dateiNrString) < 5
dateiNrString = 0 & dateiNrString
Wend
dateiName = dateiAnf & dateiNrString & dateiEnd
Application.StatusBar = dateiName
If Dir(quellPfad & dateiName) <> "" Then
' Damit keine Makroabfrage kommt
Application.DisplayAlerts = True
' Damit keine Makros ausgeführt werden
Application.EnableEvents = False
' Schreibgeschützt öffnen, ohne LinkUpdates
' dabei Fehlerbehandlung aus
On Error Resume Next
Set myWbk = Workbooks.Open(quellPfad & dateiName, False, True)
On Error GoTo 0
Application.EnableEvents = False
Application.DisplayAlerts = False
' Wenn öffnen geklappt hat
If Not myWbk Is Nothing Then
' Tabellenblätter kopieren
myWbk.Sheets.Copy
' Quellmappe zu
myWbk.Close False
Set myWbk = Nothing
' Im neu entstandenen Workbook noch alle Makros löschen
' (Makros in Tabellenblättern werden mitkopiert)
Call entFerneCode(ActiveWorkbook)
' Speichern - ohne Fehlerbehandlung
'                On Error Resume Next
ActiveWorkbook.Close True, zielPfad & dateiName
On Error GoTo 0
End If
End If
Next
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
' Entfernt den Code aus der Arbeitsmappe
Sub entFerneCode(ByRef myWbk As Workbook)
Dim codeObject As Object
For Each codeObject In myWbk.VBProject.VBComponents
With codeObject
' Alle Module (Type 1), Forms (Code 2) und Klassenmodule (Code 3) löschen
If .Type >= 1 And .Type <= 3 Then
myWbk.VBProject.VBComponents.Remove codeObject
ElseIf .Type = 100 Then
' Etwaigen Code in Tabellenblättern und DieseArbeitsmappe löschen
On Error Resume Next
.CodeModule.DeleteLines 1, .CodeModule.CountOfLines
On Error GoTo 0
End If
End With
Next
End Sub

Schau bitte bei den Konstanten ob die so passen - die Pfade wirst Du mit Sicherheit ändern müssen.
Gruss, Jogy

Hi.
Sehe grade dass ich da noch ein "On error resume next" auskommentiert habe. Da bitte das Hochkomma am Anfang der Zeile rausnehmen.
Gruss, Jogy

Hi.
Mist, da waren noch zwei Fehler drin, so ist es richtig:

Sub kopierenOhneMakros()
Const quellPfad = "C:\temp\quelle\"
Const zielPfad = "c:\temp\ziel\"
Const dateiAnf = "LS"
Const dateiEnd = ".xls"
Const dateiNrLaenge = 5
Dim dateiNr As Long
Dim dateiNrString As String
Dim dateiName As String
Dim myWbk As Workbook
Application.ScreenUpdating = False
For dateiNr = 1 To 2000 ' Nr. anpassen, darf mehr sein
dateiNrString = dateiNr
While Len(dateiNrString) < 5
dateiNrString = 0 & dateiNrString
Wend
dateiName = dateiAnf & dateiNrString & dateiEnd
Application.StatusBar = dateiName
If Dir(quellPfad & dateiName) <> "" Then
' Damit keine Makroabfrage kommt
Application.DisplayAlerts = True
' Damit keine Makros ausgeführt werden
Application.EnableEvents = False
' Schreibgeschützt öffnen, ohne LinkUpdates
' dabei Fehlerbehandlung aus
On Error Resume Next
Set myWbk = Workbooks.Open(quellPfad & dateiName, False, True)
On Error GoTo 0
Application.EnableEvents = True
Application.DisplayAlerts = True
' Wenn öffnen geklappt hat
If Not myWbk Is Nothing Then
' Tabellenblätter kopieren
myWbk.Sheets.Copy
' Quellmappe zu
myWbk.Close False
Set myWbk = Nothing
' Im neu entstandenen Workbook noch alle Makros löschen
' (Makros in Tabellenblättern werden mitkopiert)
Call entFerneCode(ActiveWorkbook)
' Speichern - ohne Fehlerbehandlung
On Error Resume Next
ActiveWorkbook.Close True, zielPfad & dateiName
On Error GoTo 0
End If
End If
Next
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
' Entfernt den Code aus der Arbeitsmappe
Sub entFerneCode(ByRef myWbk As Workbook)
Dim codeObject As Object
For Each codeObject In myWbk.VBProject.VBComponents
With codeObject
' Alle Module (Type 1), Forms (Code 2) und Klassenmodule (Code 3) löschen
If .Type >= 1 And .Type <= 3 Then
myWbk.VBProject.VBComponents.Remove codeObject
ElseIf .Type = 100 Then
' Etwaigen Code in Tabellenblättern und DieseArbeitsmappe löschen
On Error Resume Next
.CodeModule.DeleteLines 1, .CodeModule.CountOfLines
On Error GoTo 0
End If
End With
Next
End Sub

Gruss, Jogy

... irgendwie ist nicht so mein Tag... das Treu und False läuft heute wohl nach dem Zufallsprinzip... jetzt sollte es aber endgültig stimmen:

Sub kopierenOhneMakros()
Const quellPfad = "C:\temp\quelle\"
Const zielPfad = "c:\temp\ziel\"
Const dateiAnf = "LS"
Const dateiEnd = ".xls"
Const dateiNrLaenge = 5
Dim dateiNr As Long
Dim dateiNrString As String
Dim dateiName As String
Dim myWbk As Workbook
Application.ScreenUpdating = False
For dateiNr = 1 To 2000 ' Nr. anpassen, darf mehr sein
dateiNrString = dateiNr
While Len(dateiNrString) < 5
dateiNrString = 0 & dateiNrString
Wend
dateiName = dateiAnf & dateiNrString & dateiEnd
Application.StatusBar = dateiName
If Dir(quellPfad & dateiName) <> "" Then
' Damit keine Makroabfrage kommt
Application.DisplayAlerts = False
' Damit keine Makros ausgeführt werden
Application.EnableEvents = False
' Schreibgeschützt öffnen, ohne LinkUpdates
' dabei Fehlerbehandlung aus
On Error Resume Next
Set myWbk = Workbooks.Open(quellPfad & dateiName, False, True)
On Error GoTo 0
Application.EnableEvents = True
Application.DisplayAlerts = True
' Wenn öffnen geklappt hat
If Not myWbk Is Nothing Then
' Tabellenblätter kopieren
myWbk.Sheets.Copy
' Quellmappe zu
myWbk.Close False
Set myWbk = Nothing
' Im neu entstandenen Workbook noch alle Makros löschen
' (Makros in Tabellenblättern werden mitkopiert)
Call entFerneCode(ActiveWorkbook)
' Speichern - ohne Fehlerbehandlung
On Error Resume Next
ActiveWorkbook.Close True, zielPfad & dateiName
On Error GoTo 0
End If
End If
Next
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
' Entfernt den Code aus der Arbeitsmappe
Sub entFerneCode(ByRef myWbk As Workbook)
Dim codeObject As Object
For Each codeObject In myWbk.VBProject.VBComponents
With codeObject
' Alle Module (Type 1), Forms (Code 2) und Klassenmodule (Code 3) löschen
If .Type >= 1 And .Type <= 3 Then
myWbk.VBProject.VBComponents.Remove codeObject
ElseIf .Type = 100 Then
' Etwaigen Code in Tabellenblättern und DieseArbeitsmappe löschen
On Error Resume Next
.CodeModule.DeleteLines 1, .CodeModule.CountOfLines
On Error GoTo 0
End If
End With
Next
End Sub

Hallo JogyB,
leider stürtzt das Proggy immer noch ab.
Ich glaube bei "myWbk.Sheets.Copy"
Ihr habt Euch bisher so viel Mühe gegeben, villeicht kannst Du nochmal raufschauen.
Gruß
Carsten

Hallo JogyB,
Hängt sich beim Ausführen von Unterprogramm "Sub entFerneCode(ByRef myWbk As Workbook)" auf
Wenn ich den "Call" dazu mit ' deaktiviere, dann wird die 1. Datei ins neue Verzeichnis kopiert (Passswort ist weg , Module sind auch weg...Wunderbar und ein paar kleiner Restmakros in den Blättern sind noch ...das könnte aber auch so bleiben). Aber bei der Schleife zur 2. Datei kommt Windows Fehlermeldung (also nicht Debuggen)...
Ich glaube es ist dicht drann...
Gruß
Carsten

Hallo Carstma,
sorry dass ich mich nicht gemeldet hatte.
Ich dachte eigentlich daran, nicht die Sheets zu kopieren, sondern ausschließlich deren Inhalt. Somit sollten keine Makros in der abgespeicherten Arbeitsmappe sein.
Versuche mal folgenden Code:

Sub test()
Dim lngCount As Integer
Dim varDateiname As Variant
Dim n As Integer
Dim Suchpfad As String, Dateiform As String, speicherpfad As String, speicherpfad1 As  _
String, tabname As String, datname As String
Dim totFiles As Long
Suchpfad = InputBox("Geben Sie den Ordner an, der durchsucht werden soll.", "Pfad  _
definieren", "C:\Dokumente und Einstellungen\admin\Desktop\neuer ordner")
If Suchpfad = "" Then Exit Sub
Dateiform = InputBox("Bitte die Endung der Dateiform definieren", "Dateierweiterung", "xls") _
If Dateiform = "" Then Exit Sub
speicherpfad = InputBox("Geben Sie den Ordner an, in den abgespeichert werden soll.", "Pfad  _
definieren", "C:\Dokumente und Einstellungen\admin\Desktop\neuer ordner1")
If speicherpfad = "" Then Exit Sub
With Application.FileSearch
.LookIn = Suchpfad
.SearchSubFolders = True
.Filename = Dateiform
If .Execute() > 0 Then
totFiles = .FoundFiles.Count
' Bildschirmaktualisierung deaktivieren
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Ausgewählte Dateien öffnen
For lngCount = 1 To totFiles              ' Anzahl der Dateien
Workbooks.Add
varDateiname = .FoundFiles(lngCount)
If varDateiname <> False Then                   ' Test auf gültigen Dateinamen
' CSV-Dateien öffnen, Meßwerte lesen und Datei schließen
Workbooks.OpenText Filename:=varDateiname, Origin:= _
xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=True,  _
_
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1),  _
_
Array(2, 1)), local:=True
datname = Workbooks(3).Name
speicherpfad1 = speicherpfad & "\" & datname
For n = 1 To Workbooks(3).Sheets.Count
Workbooks(3).Activate
tabname = ActiveWorkbook.Sheets(n).Name
ActiveWorkbook.Sheets(n).Activate
Range(Cells(1, 1), Cells(64000, 100)).Select 'Hier anpassen!!!!!!!!!!!!! _
111
Selection.Copy
Workbooks(2).Activate
Sheets(n).Activate
Cells(1, 1).Activate
Selection.PasteSpecial
ActiveWorkbook.Sheets(n).Name = tabname
Next n
Application.CutCopyMode = False
Windows(datname).Activate
ActiveWindow.Close
Workbooks(2).Activate
Workbooks(2).SaveAs speicherpfad1
Workbooks(2).Close
Application.CutCopyMode = True
End If
Next lngCount
End If
End With
End Sub

Gruß
welga