Informationen und Beispiele zum Thema InputBox | |
---|---|
![]() |
InputBox-Seite mit Beispielarbeitsmappe aufrufen |
Informationen und Beispiele zum Thema MsgBox | |
---|---|
![]() |
MsgBox-Seite mit Beispielarbeitsmappe aufrufen |
Betrifft: Arbeitsmappen Öffnen per Schleife
von: carstma
Geschrieben am: 04.12.2009 13:56:25
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!!
Betrifft: AW: Arbeitsmappen Öffnen per Schleife
von: welga
Geschrieben am: 04.12.2009 14:18:06
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
Betrifft: AW: Arbeitsmappen Öffnen per Schleife
von: carstma
Geschrieben am: 04.12.2009 15:02:30
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
Betrifft: AW: Arbeitsmappen Öffnen per Schleife
von: Josef Ehrensberger
Geschrieben am: 04.12.2009 18:15:15
Hallo Carsten,
ich hab mal welga's Idee in meinen Code eingebaut.
Betrifft: AW: Arbeitsmappen Öffnen per Schleife
von: JogyB
Geschrieben am: 04.12.2009 14:55:52
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
Betrifft: AW: Arbeitsmappen Öffnen per Schleife
von: JogyB
Geschrieben am: 04.12.2009 15:09:05
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
Betrifft: AW: Arbeitsmappen Öffnen per Schleife
von: JogyB
Geschrieben am: 04.12.2009 15:27:18
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
Betrifft: AW: so langsam ist es peinlich...
von: JogyB
Geschrieben am: 04.12.2009 16:29:17
... 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
Betrifft: AW: so langsam ist es peinlich...
von: carstma
Geschrieben am: 07.12.2009 11:04:30
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
Betrifft: AW: so langsam ist es peinlich...
von: carstma
Geschrieben am: 07.12.2009 13:30:09
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
Betrifft: AW: Arbeitsmappen Öffnen per Schleife
von: welga
Geschrieben am: 10.12.2009 09:45:47
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