Arbeitsmappen Öffnen per Schleife

Bewerten Sie hier bitte das Excel-Portal

Der kurze Weg zum Ziel: Auftragsprogrammierung

Informationen und Beispiele zum Thema InputBox
Screenshot zu InputBox	InputBox-Seite mit Beispielarbeitsmappe aufrufen

Informationen und Beispiele zum Thema MsgBox
Screenshot zu MsgBox	MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Arbeitsmappen Öffnen per Schleife | Herbers Excel-Forum

Arbeitsmappen Öffnen per Schleife von carstma vom 04.12.2009 13:56:25

AW: Arbeitsmappen Öffnen per Schleife - von welga am 04.12.2009 14:18:06
- AW: Arbeitsmappen Öffnen per Schleife - von carstma am 04.12.2009 15:02:30
  - AW: Arbeitsmappen Öffnen per Schleife - von Josef Ehrensberger am 04.12.2009 18:15:15
AW: Arbeitsmappen Öffnen per Schleife - von JogyB am 04.12.2009 14:55:52
- AW: Arbeitsmappen Öffnen per Schleife - von JogyB am 04.12.2009 15:09:05
  - AW: Arbeitsmappen Öffnen per Schleife - von JogyB am 04.12.2009 15:27:18
    - AW: so langsam ist es peinlich... - von JogyB am 04.12.2009 16:29:17
      - AW: so langsam ist es peinlich... - von carstma am 07.12.2009 11:04:30
        
        AW: so langsam ist es peinlich... - von carstma am 07.12.2009 13:30:09
AW: Arbeitsmappen Öffnen per Schleife - von welga am 10.12.2009 09:45:47

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.

' **********************************************************************
' 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

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

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

Gruss, Jogy

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

Gruss, Jogy

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

Gruß
welga