alle xls eines Ordners öffen, Wert kopieren

Sub makro01() Dim i As Integer, letzte As Integer Dim Tabellen As Integer Application.DisplayAlerts = False With Application.FileSearch .NewSearch .LookIn = ("C:\\eigene Dateien\eigene Dokumente\Januar") .SearchSubFolders = False .Filename = "*.xls" If .Execute() > 0 Then For i = 1 To .FoundFiles.Count Workbooks.Open Filename:=.FoundFiles(i) For Tabellen = 1 To Sheets.Count Workbooks(2).Worksheets(Tabellen).Columns("A:C").Replace _ what:="#", replacement:=" ", searchorder:=xlByColumns, MatchCase:=True Next Tabellen Workbooks(2).Save Workbooks(2).Close Next i End If End With Application.DisplayAlerts = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub makro01() Dim i As Integer, letzte As Integer Application.DisplayAlerts = False With Application.FileSearch .NewSearch .LookIn = ("C:\\eigene Dateien\eigene Dokumente\Januar") ' Hier dein Pfad .SearchSubFolders = False .Filename = "*.xls" If .Execute() > 0 Then For i = 1 To .FoundFiles.Count Workbooks.Open Filename:=.FoundFiles(i) ActiveWorkbook.Sheets(1).Range("P14").Copy ThisWorkbook.Sheets(1).Range("A65536").End(xlup). _ Offset(1, 0) ActiveWorkbook.Close Next i End If End With Application.DisplayAlerts = True End Sub

Sub Open_Workbooks() ' Open_Workbooks Makro ' Makro am 25.02.2008 von demftws5 aufgezeichnet Dim i As Integer, letzte As Integer ' Variable ist ganzzahlig Application.DisplayAlerts = False ' Was genau bringt dieser Befehl? With Application.FileSearch .NewSearch 'Applikation Suche .LookIn = ("I:\PE_SW\SW\01 - Team Organization\a - Team Members\Werkstudenten & Azubis\Jens\ _ Reporting") .SearchSubFolders = False .Filename = "*.xls" If .Execute() > 0 Then ' ist das eine wenn-dann-Funktion? wenn du mehr als 0 xls-Dokumente findest? For i = 1 To .FoundFiles.Count Workbooks.Open Filename:=.FoundFiles(i) ActiveWorkbook.Sheets("Summary").Range("O14").Copy ThisWorkbook.Sheets("Summary").Range("A65536" _ ).End(xlUp). _ Offset(1, 0) ' das heißt er macht nach jedem eingefügten Wert einen Absatz, oder? ActiveWorkbook.Close Next i ' das heißt nach i=x, kommt i=x+1, oder? End If ' Ende der wenn-dann-Funktion? End With ' Ende der Suchapplikation? Application.DisplayAlerts = True End Sub

Servus,
Erläuterungen im Makrotext:


Sub Open_Workbooks()
' Open_Workbooks Makro
' Makro am 25.02.2008 von demftws5 aufgezeichnet
Dim i As Integer, letzte As Integer
' Variable ist ganzzahlig
Application.DisplayAlerts = False
' Was genau bringt dieser Befehl? Er schaltet die Fehlermeldungen bzw. Abfragen von Excel aus,  _
z.B.: Wollen Sie die Änderungen in ...xls speichern?
With Application.FileSearch
.NewSearch
'Applikation Suche
.LookIn = "I:\PE_SW\SW\01 - Team Organization\a - Team Members\Werkstudenten & Azubis\Jens\ _
Reporting" ' Die Klammern braucht man nicht
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
' ist das eine wenn-dann-Funktion? wenn du mehr als 0 xls-Dokumente findest? D.h.:Wenn mind.  _
eine Datei da ist, dann führ die Schleife aus., wenn nicht dann nicht.
For i = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(i)
ActiveWorkbook.Sheets("Summary").Range("O14").Copy ThisWorkbook.Sheets("Summary").Range("A65536" _
_
).End(xlUp). _
Offset(1, 0)
' das heißt er macht nach jedem eingefügten Wert einen Absatz, oder? Ja, beginnend in A2 und  _
dann immer in jede nächste freie Zelle in Spalte A
ActiveWorkbook.Close
Next i
' das heißt nach i=x, kommt i=x+1, oder? z.B.: Wenn 2 gefunden wurden, dann i = 1 Next i, i = 2  _
Ende
End If
' Ende der wenn-dann-Funktion? ' Ende Execute()
End With
' Ende der Suchapplikation? ' Ende Filesearch
Application.DisplayAlerts = True ' Alarmmeldungen wieder einschalten
End Sub

Funktioniert's denn jetzt?
Gruß
Chris

Hallo Jens,
ich hatte schon mal ein ähnliches Problem, nur dass ich mehrere hundert Dateien bearbeiten musste - deshalb habe ich dieses Makro geschrieben (die Anpassung an Deine Anforderungen erfolgt im Bereich "Benutzerdefinition":

Sub prcZellenwertHolen()
    Dim oFileSystem As Object, oFolder As Object, oFile   As Object
    Dim sPfad       As String, sZelle  As String, sFormel As String, sBlatt As String
    Dim iZeile      As Long, iSpalte   As Long

    '### Benutzerdefinition ###########################################################
        sPfad = "I:\Ordner"     'Pfad mit XLS-Dateien angeben
        sBlatt = "Tabelle1"     'Wert in Tabelle sBlatt suchen
        sZelle = "P14"          'Zelle zum summieren angeben
        iSpalte = 2             'Ausgabe in Spalte iSpalte beginnen
        iZeile = 2              'Ausgabe in Zeile iZeile beginnen
    '##################################################################################

    sBlatt = sBlatt & "'!"
    Set oFileSystem = CreateObject("Scripting.FilesystemObject")
    Set oFolder = oFileSystem.getFolder(sPfad)
    For Each oFile In oFolder.Files
        If oFile.Type = "Microsoft Excel-Arbeitsblatt" Then 'Nur Exceldateien suchen
            sFormel = "='" & sPfad & "\[" & oFile.Name & "]" & sBlatt & sZelle
            With ThisWorkbook.ActiveSheet
                .Cells(iZeile, iSpalte) = oFile.Name 'Dateinamen ausgeben
                .Cells(iZeile, iSpalte + 1).Formula = sFormel 'gefundenden Wert ausgeben
                .Cells(iZeile, iSpalte + 1) = .Cells(iZeile, iSpalte + 1).Value 'Wertkopie
            End With
            iZeile = iZeile + 1
        End If
    Next oFile
    Set oFolder = Nothing
    Set oFileSystem = Nothing
End Sub

Gruß
CS

Beliebteste Forumthreads (12 Monate)

alle xls eines Ordners öffen, Wert kopieren

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread