Dateien in Ordner öffnen,Makro ausführen,speichern

Bild

Betrifft: Dateien in Ordner öffnen,Makro ausführen,speichern
von: braun
Geschrieben am: 07.09.2015 11:00:50

Guten Tag,
ich bin seit Tagen auf der Suche nach einem Makro, werde aber einfach nicht fündig.
In einem Ordner befinden sich viele Excel-Dateien, die alle die gleiche Struktur haben.
Ich öffne nun jede Datei einzeln, kopiere den Inhalt in die Exceldatei mit meinem Makro, lasse das Makro laufen und speicher es wieder unter dem alten Namen in dem Ordner ab.
Das Makro läuft super, allerdings ist das alles sehr aufwendig, da in dem Ordner sehr viele Dateien sind.
Ich bräuchte nun ein Makro, dass alle Dateien in dem Ordner nacheinander öffnet, das Makro darüber laufen lässt, und anschließend überspeichert.
Habe in verschiedenen Foren schon Codes gefunden, allerdings kann man dort nur einen Code eingeben,das Makro dass ich erstellt habe ,besteht aber aus vier Teilen und wird über Call-Funktionen abgerufen.
Wäre super wenn mir jemand helfen kann!
Vielen Dank im Voraus
karin

Bild

Betrifft: Dateien in Ordner öffnen,Makro ausführen
von: Rudi Maintaire
Geschrieben am: 07.09.2015 12:26:46
Hallo,
allerdings kann man dort nur einen Code eingeben
na und?
Dann gib eben alle 4 an.
Keiner weiß, was du gefunden hast und wie deine Makros aussehen.
Gruß
Rudi

Bild

Betrifft: AW: Dateien in Ordner öffnen,Makro ausführen
von: braun
Geschrieben am: 07.09.2015 13:02:16
Den Code finde ich leider nicht mehr, aber er hat auch nicht funktioniert, auch nicht, wenn ich alle Makrocodes mit einbette. Hatte gehofft es gibt vielleicht die Möglichkeit, meine geschriebenen Makros so stehen zu lassen, und in dem neuen MakroCode per Call Funktion diese aufzurufen.
Hier sind meine 4 Makros (stark verkürzt und abgeändert) für einen groben Überblick

 grenzwert And Sheets(1).Cells(i, Spalte2) = grenzwert2 And  _
Sheets(1).Cells(i, Spalte3) = grenzwert3 Then
        'hier copieren der Zellinhalte
        Sheets(1).Rows(i & ":" & i).Copy
        Sheets(2).Select
        Cells(startzeile2, 1).Select
        ActiveSheet.Paste
        startzeile2 = startzeile2 + 1
        
     Else
     End If
Next
    
'Filter einbauen
    
    Rows("1:1").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    
'Überschriften fixieren
 
    Range("A2").Activate
    ActiveWindow.FreezePanes = True
    
'Spaltengröße anpassen
    Columns("A:W").EntireColumn.AutoFit
    
End Sub
pre>

Bild

Betrifft: AW: Dateien in Ordner öffnen,Makro ausführen
von: braun
Geschrieben am: 07.09.2015 13:05:35
Da ist jetzt was schief gelaufen, hier nochmal der ganze Code

Private Sub Makro1()
'Tabelle aufbereiten
       
'Spalten löschen
    Range("A:A,C:C,E:E,BF:DC").Delete
'neue Spalten einfügen
    Columns("G:G").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    
    Range("H2").Select
    ActiveCell.FormulaR1C1 = "AAAA"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "BBB"
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "CCC"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "DDD"
    
    'Formel:Datumsformat ändern
    
Range("G3").Select
    ActiveCell.FormulaR1C1 = _
    "=IF(ISERROR((DATE(LEFT(RC[2],4),MID(RC[2],5,2),RIGHT(RC[2],2)))),""ohne Datum"",DATE(LEFT( _
RC[2],4),MID(RC[2],5,2),RIGHT(RC[2],2)))"
    With ActiveSheet
'letzte Zeile auffinden:
    lngLetzte = .UsedRange.Rows.Count + .UsedRange.Row - 1
'Formel aus G3 runterziehen
    .Range(.Cells(3, 7), Cells(lngLetzte, 7)).Formula = .Cells(3, 7).Formula
    End With
   
Range("H3").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(ISERROR((DATE(LEFT(RC[-2],4),MID(RC[-2],5,2),RIGHT(RC[-2],2)))),""ohne Datum"", _
DATE(LEFT(RC[-2],4),MID(RC[-2],5,2),RIGHT(RC[-2],2)))"
     
     
    With ActiveSheet
'letzte Zeile auffinden:
    lngLetzte = .UsedRange.Rows.Count + .UsedRange.Row - 1
'Formel aus H3 runterziehen
    .Range(.Cells(3, 8), Cells(lngLetzte, 8)).Formula = .Cells(3, 8).Formula
    End With
 Columns("G:H").Select
    Selection.NumberFormat = "m/d/yyyy"
    
End Sub

Private Sub Makro2()
    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "BBBBBBBBB"
    Range("H2").Select
    ActiveCell.FormulaR1C1 = "BBBBBBBBB"
    
End Sub
Private Sub Makro3()
    Range("H3").Select
    ActiveCell.FormulaR1C1 = "=IF(ISERROR(IF(RC[1]="""",99,NETWORKDAYS(RC[-1],RC[1]))-1),"""", _
IF(RC[1]="""",99,NETWORKDAYS(RC[-1],RC[1]))-1)"
    
    
   
    Columns("H:H").Select
    Selection.NumberFormat = "0"
    
    
       With ActiveSheet
'letzte Zeile auffinden:
    lngLetzte = .UsedRange.Rows.Count + .UsedRange.Row - 1
'Formel aus H3 runterziehen
    .Range(.Cells(3, 8), Cells(lngLetzte, 8)).Formula = .Cells(3, 8).Formula
    End With
    
Rows("1:1").Select
Selection.Delete Shift:=xlUp
'Filter einbauen
    
    Rows("1:1").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    
    
'Spaltengröße anpassen
Columns("A:P").EntireColumn.AutoFit
End Sub
Private Sub Makro4()
Sheets(1).Select
    Sheets.Add After:=Sheets(1)
        Sheets(2).Name = "ABC"
Sheets(1).Select
    Rows("1:2").Select
    Selection.Copy
Sheets(2).Select
    Range("A1").Select
    ActiveSheet.Paste
Sheets(1).Select
startzeile = 2
'Spalte die geprüft wird
Spalte = 5
grenzwert = 5
startzeile2 = 2
Spalte2 = 10
Spalte3 = 1
grenzwert2 = "TEST"
grenzwert3 = "TEST2"
Sheets(1).Select
Letzte_Zeile = Range(Cells(65536, Spalte), Cells(65536, Spalte)).End(xlUp).Row
For i = startzeile To Letzte_Zeile
On Error Resume Next
     If Sheets(1).Cells(i, Spalte) > grenzwert And Sheets(1).Cells(i, Spalte2) = grenzwert2 And  _
Sheets(1).Cells(i, Spalte3) = grenzwert3 Then
        'hier copieren der Zellinhalte
        Sheets(1).Rows(i & ":" & i).Copy
        Sheets(2).Select
        Cells(startzeile2, 1).Select
        ActiveSheet.Paste
        startzeile2 = startzeile2 + 1
        
     Else
     End If
Next
    
'Filter einbauen
    
    Rows("1:1").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    
'Überschriften fixieren
 
    Range("A2").Activate
    ActiveWindow.FreezePanes = True
    
'Spaltengröße anpassen
    Columns("A:W").EntireColumn.AutoFit
    
End Sub


Bild

Betrifft: AW: Dateien in Ordner öffnen,Makro ausführen
von: Rudi Maintaire
Geschrieben am: 07.09.2015 13:12:20
hallo,
sollte doch so funktionieren:

Sub alle()
  Dim sFile As String, wkb As Workbook
  Const sPfad As String = "c:\test\"
  sFile = Dir(sPfad & "*.xls*")
  Do While sFile <> ""
    Set wkb = Workbooks.Open(sPfad & sFile)
    Call Makro1
    Call Makro2
    Call Makro3
    Call Makro4
    wkb.Close True
    sFile = Dir
  Loop
End Sub

Gruß
Rudi

Bild

Betrifft: AW: Dateien in Ordner öffnen,Makro ausführen
von: braun
Geschrieben am: 07.09.2015 15:46:14
Das klappt super, danke!

Bild

Betrifft: dann zu...oT
von: robert
Geschrieben am: 08.09.2015 10:01:44


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Dateien in Ordner öffnen,Makro ausführen,speichern"