Makros in mehreren Dateien ausführen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Guten Morgen,
anbei die von mir bisher gestaltete Masterdatei, die die eingebundenen Makros in den Exceldateinen eines anderen Ordners ausführen sollen.
Denke der Zugriff auf den anderen Ordner ist noch nicht korrekt, also nicht vorhanden. Makro dürfte bisher nur auf den Ordner zugreifen, in dem sich die Masterdatei selbstbefindet. Und der Aufruf der Call Anweisung funktioniert ebenso nicht.


Sub AnwendungMakrosVerzeichnis()
Dim Verz As Folder  'Verzeichniss-Objekt anlegen
Dim Datei As File   'Datei-Objekt anlegen
Dim wb As Workbook
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
'Das Verzeichniss-Objekt mit dem Verzeichniss
'der geöffneten Datei zuweisen:
Set Verz = fso.GetFolder(ActiveWorkbook.Path)
'Nun alle Dateien in dem Ordner durchgehen
For Each Datei In Verz.Files
'Wenn es eine Excel Datei ist
If UCase(Right(Datei.Name, 3)) = "XLS" Then
'Wenn die Datei noch nicht geoeffnet ist oeffnen
If Not WorkbookIsOpen(Datei.Name) Then
If Right(Datei.Path, 1) = "\" Then
Workbooks.Open Datei.Path
Else
Workbooks.Open Datei.Path
End If
End If
'Die Datei zuweisen und aktivieren
Set wb = Workbooks(Datei.Name)
wb.Activate
'hier nun dein Makro aufrufen
Call ZeilenLöschen
Call SpalteLöschen
Call SpaltenLöschen
Call SpaltenLöschen1
Call TabellenblattLöschen
Call TabellenblattLöschen1
'eventuell die Datei speichern und schliessen
wb.Save
wb.Close
End If
Next
End Sub

'Pruefung ob die Datei schon in Excel geoeffnet ist


Function WorkbookIsOpen( _
ByVal WorkbName As String _
) As Boolean
Dim wb As Workbook
For Each wb In Workbooks
If wb.Name = WorkbName Then
WorkbookIsOpen = True
Exit Function
End If
Next
WorkbookIsOpen = False
End Function


Sub ZeilenLöschen()
Sheets("Close").Activate
Rows("2:18").Select
Selection.Delete Shift:=xlUp
End Sub


Sub SpalteLöschen()
Sheets("Close").Activate
Range("E1").Select
ActiveCell.EntireColumn.Delete
End Sub


Sub SpaltenLöschen()
Sheets("Close").Activate
Columns("F:P").Select
Selection.Delete Shift:=xlToLeft
End Sub


Sub SpaltenLöschen1()
Sheets("Close").Activate
Columns("G:K").Select
Selection.Delete Shift:=xlToLeft
End Sub


Sub TabellenblattLöschen()
Application.DisplayAlerts = False
Sheets(2).Delete
End Sub


Sub TabellenblattLöschen1()
Application.DisplayAlerts = False
Sheets(2).Delete
End Sub

Hoffe ich habe alle wichtigen Infos angegeben. Falls ein Pfad hinterlegt werden muss, kann einfach ein Beispielpfad integriert werden, änder den dann ab.
Vielen Dank!

Hallo Ulf,
ÜProbier mal, ich habe die Umgebung jetzt nicht nachgebaut.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub AnwendungMakrosVerzeichnis()
    Dim strInitialPath As String, strpath As String
    Dim objWB As Workbook
    Dim objFSO As Object
    Dim objFSODirectory As Object 'Verzeichniss-Objekt anlegen
    Dim objFSOFile As Object 'Datei-Objekt anlegen

    On Error GoTo ErrExit
    GMS

    strInitialPath = "C:\" 'Root-Verzeichnis zur Verzeichnisauswahl

    strpath = fncBrowseForFolder(strInitialPath)

    If strpath = "" Then GoTo ErrExit

    Set objFSO = CreateObject("Scripting.FileSystemObject")

    'Das Verzeichniss-Objekt mit dem Verzeichniss
    'der geöffneten objFSOFile zuweisen:

    Set objFSODirectory = objFSO.GetFolder(strpath)

    'Nun alle Dateien in dem Ordner durchgehen
    For Each objFSOFile In objFSODirectory.Files

        'Wenn es eine Excel objFSOFile ist
        If UCase(Right(objFSOFile.Name, 3)) = "XLS" Then

            'Wenn die objFSOFile noch nicht geoeffnet ist oeffnen
            If Not WorkbookIsOpen(objFSOFile.Name) Then
                Set objWB = Workbooks.Open(objFSOFile.Path)
            Else
                Set objWB = Workbooks(objFSOFile.Name)
            End If

            objWB.Activate

            'hier nun dein Makro aufrufen
            Call ZeilenLöschen
            Call SpalteLöschen
            Call SpaltenLöschen
            Call SpaltenLöschen1
            Call TabellenblattLöschen
            Call TabellenblattLöschen1
            'eventuell die objFSOFile speichern und schliessen
            objWB.Close True
            Set objWB = Nothing
        End If

    Next
    ErrExit:
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & vbLf & _
        "Beschreibung: " & Err.Description, vbExclamation, "Fehler"

    GMS True
    Set objFSO = Nothing
    Set objFSOFile = Nothing
    Set objFSODirectory = Nothing
    Set objWB = Nothing
End Sub

Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
    Dim objFlderItem As Object, objShell As Object, objFlder As Object

    Set objShell = CreateObject("Shell.Application")
    Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)

    If objFlder Is Nothing Then GoTo ErrExit

    Set objFlderItem = objFlder.Self
    fncBrowseForFolder = objFlderItem.Path

    ErrExit:

    Set objShell = Nothing
    Set objFlder = Nothing
    Set objFlderItem = Nothing
End Function

'Pruefung ob die objFSOFile schon in Excel geoeffnet ist

Function WorkbookIsOpen( _
        ByVal WorkbName As String _
        ) As Boolean

    Dim objWB As Workbook

    For Each objWB In Workbooks
        If objWB.Name = WorkbName Then
            WorkbookIsOpen = True
            Exit Function
        End If
    Next

End Function

Private 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
        .Calculation = IIf(Modus, lngCalc, -4135)
        .Cursor = IIf(Modus, -4143, 2)
    End With

End Sub

Sub ZeilenLöschen()
    ActiveWorkbook.Sheets("Close").Rows("2:18").Delete Shift:=xlUp
End Sub

Sub SpalteLöschen()
    ActiveWorkbook.Sheets("Close").Range("E1").EntireColumn.Delete
End Sub

Sub SpaltenLöschen()
    ActiveWorkbook.Sheets("Close").Columns("F:P").Delete Shift:=xlToLeft
End Sub

Sub SpaltenLöschen1()
    ActiveWorkbook.Sheets("Close").Columns("G:K").Delete Shift:=xlToLeft
End Sub

Sub TabellenblattLöschen()
    Application.DisplayAlerts = False
    ActiveWorkbook.Sheets(2).Delete
    Application.DisplayAlerts = True
End Sub

Sub TabellenblattLöschen1()
    Application.DisplayAlerts = False
    ActiveWorkbook.Sheets(2).Delete
    Application.DisplayAlerts = True
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Makros in mehreren Dateien ausführen

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Makros in mehreren Dateien ausführen

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread