Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1120to1124
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Arbeitsmappen Öffnen per Schleife
carstma
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!!
AW: Arbeitsmappen Öffnen per Schleife
04.12.2009 14:18:06
welga
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
AW: Arbeitsmappen Öffnen per Schleife
04.12.2009 15:02:30
carstma
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
Anzeige
AW: Arbeitsmappen Öffnen per Schleife
04.12.2009 18:15:15
Josef
Hallo Carsten,
ich hab mal welga's Idee in meinen Code eingebaut.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub saveFilesWithoutCode()
  Dim objWB As Workbook, objWbNew As Workbook, objSh As Worksheet
  Dim strPath As String, strNewPath As String, strFile As String
  
  On Error GoTo ErrExit
  GMS
  
  strPath = "E:\Temp\" 'Verzeichnis - Anpassen!
  
  strNewPath = "E:\Temp\Test" 'Speicherpfad - Anpassen!
  
  If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  
  If Right(strNewPath, 1) <> "\" Then strNewPath = strNewPath & "\"
  
  strFile = Dir(strPath & "*.xls*", vbNormal)
  
  Do While strFile <> ""
    Set objWB = Workbooks.Open(strPath & strFile)
    Set objWbNew = Workbooks.Add(xlWBATWorksheet)
    objWbNew.Sheets(1).Name = "xxxxxxxxxxxxxxxxxxxxxxxxx"
    For Each objSh In objWB.Worksheets
      objSh.Copy after:=objWbNew.Sheets(objWbNew.Sheets.Count)
    Next
    objWbNew.Sheets(1).Delete
    deleteAllCodeAndModules objWbNew
    objWB.Close False
    objWbNew.SaveAs strNewPath & strFile
    objWbNew.Close
    strFile = Dir
  Loop
  
  ErrExit:
  With Err
    If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
      .Description & vbLf & vbLf & "In Prozedur (saveFilesWithoutCode) in Modul Modul3", _
      vbExclamation, "Fehler in Modul3 / saveFilesWithoutCode"
  End With
  
  GMS True
  
  Set objWB = Nothing
End Sub

Sub deleteAllCodeAndModules(ByRef WBook As Workbook)
  Dim objVBComp As Object
  With WBook.VBProject
    For Each objVBComp In .vbcomponents
      If objVBComp.Type = 100 Then
        With .vbcomponents(objVBComp.Name).CodeModule
          .DeleteLines 1, .CountOfLines
        End With
      Else
        .vbcomponents.Remove objVBComp
      End If
    Next
  End With
End Sub

Sub GMS(Optional ByVal Modus As Boolean = False)
  
  Static lngCalc As Long
  
  With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Not Modus Then lngCalc = .Calculation
    If Modus And lngCalc = 0 Then lngCalc = -4105
    .Calculation = IIf(Modus, lngCalc, -4135)
    .Cursor = IIf(Modus, -4143, 2)
    
  End With
  
End Sub

Gruß Sepp

Anzeige
AW: Arbeitsmappen Öffnen per Schleife
04.12.2009 14:55:52
JogyB
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)  "" 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 

Schau bitte bei den Konstanten ob die so passen - die Pfade wirst Du mit Sicherheit ändern müssen.
Gruss, Jogy
Anzeige
AW: Arbeitsmappen Öffnen per Schleife
04.12.2009 15:09:05
JogyB
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
AW: Arbeitsmappen Öffnen per Schleife
04.12.2009 15:27:18
JogyB
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)  "" 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 

Gruss, Jogy
Anzeige
AW: so langsam ist es peinlich...
04.12.2009 16:29:17
JogyB
... 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)  "" 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 

Anzeige
AW: so langsam ist es peinlich...
07.12.2009 11:04:30
carstma
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
AW: so langsam ist es peinlich...
07.12.2009 13:30:09
carstma
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
Anzeige
AW: Arbeitsmappen Öffnen per Schleife
10.12.2009 09:45:47
welga
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
Anzeige

299 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige