PDA

Vollständige Version anzeigen : Dateien eines kompletten Ordner auslesen anschließend


skater57
10.07.2015, 10:28
Hallo VBA Profis

ich hoffe es kann mir jemand helfen, mein Vorhaben ist mit VBA alle ExcelDateien (xls) eines Ordners, den Inhalt in eine zu kopieren, nach dieser Aktion die Dateien zu löschen, damit der Ordner für die nächste Aktion wieder leer ist.

Ich hoffe ich habe die Aufgabenstellung richtig beschrieben.

Im Voraus vielen Dank für eure Hilfe

Gruß Skater57

Beverly
10.07.2015, 10:40
Hi,

hier ein prinzipieller Code für das Öffnen aller Arbeitsmappen in einem festegelegten Ordner und fortlaufende Übertragen von Zellinhalten:

Sub mehrere_arbeitsmappen_oeffnen()
Dim strVerzeichnis As String
Dim strTyp As String
Dim strDateiname As String
Dim lngZeile As Long
strTyp = "*.xls"
Application.ScreenUpdating = False
strVerzeichnis = "D:\Test\"
strDateiname = Dir(strVerzeichnis & strTyp)
lngZeile = 1
With ThisWorkbook.Worksheets("Tabelle1")
Do While strDateiname <> ""
Workbooks.Open Filename:=strVerzeichnis & strDateiname
.Cells(lngZeile, 1) = ActiveWorkbook.ActiveSheet.Cells(12, 1)
ActiveWorkbook.Close True
strDateiname = Dir
lngZeile = lngZeile + 1
Loop
End With
Application.ScreenUpdating = True
End Sub



Was und wohin kopiert werden soll musst du noch anpassen.

Für das Löschen der Mappen im Ordner würde ich empfehlen, dies erst dann auszuführen, wenn alle Mappen ausgelesen wurden, denn falls Excel (aus was für Gründen auch immer) zwischendurch abstürzt, dann hast du die Brille auf ;) , weil die Mappen dann weg sind.

<hr width="20%" align="left"><img src="http://excel-inn.de/images/grusz.gif" height=35" align="left" alt="Grußformel"><a href="http://excel-inn.de/"><img border="0" src="http://excel-inn.de/images/logo1.gif" height=35" align="middle" alt="Beverly's Excel - Inn"></a>

skater57
10.07.2015, 14:55
Hallo Karin,

zuerst mal vielen Dank für Deine Antwort.

Zuerst habe ich gedacht da passiert ja gar nichts, dann bin ich den Code schrittweise durch gegangen, ich musste die Zeile "ActiveWorkbook.Close True" deaktivieren, danach waren alle vorhandenen Dateien des Ordners, geöffnet, ich brauche aber den Inhalt aller Dateien von Tabellenblatt1 in einem Tabelleblatt damit ich mein Vorhaben umsetzen kann.

Wie kann ich dies mit VBA machen?

Gruss Skater57

Beverly
10.07.2015, 16:33
Hi,

die von dir auskommentierte Zeile ist schon korrekt, denn nach erfolgten Übertragen der Daten soll die Mappe doch wieder geschlossen werden.
Dein Problem liegt darin, dass niemand außer dir weiß, WAS übernommen werden soll - dashalb habe ich ja geschrieben, dass dies ein prinzipieller Code ist und du das Kopieren selbst anpassen musst. Derzeit wird in die laufende Zelle der Spalte A der Inhalt aus Zelle A12 des in der anderen Arbeitsmappe gerade aktiven Tabellenblattes übernommen - und genau diesen Teil musst du an deine Bedingungen abpassen, keine anderen Codeteile.

<hr width="20%" align="left"><img src="http://excel-inn.de/images/grusz.gif" height=35" align="left" alt="Grußformel"><a href="http://excel-inn.de/"><img border="0" src="http://excel-inn.de/images/logo1.gif" height=35" align="middle" alt="Beverly's Excel - Inn"></a>

2013Excel
10.07.2015, 16:42
Hallo

und was hälst du hiervon:

http://www.excelformeln.de/formeln.html?welcher=126

(nicht getestet)

aloys78
11.07.2015, 05:39
Hallo Skater,
Ich hoffe ich habe die Aufgabenstellung richtig beschrieben.
Das kannst eigentlich nur Du selbst beurteilen.

Ansonsten hast Du wichtige Informationen für einen Lösungsvorschlag gar nicht erst erwähnt.

Deshalb habe ich den Code meiner Sammlung nur ergänzt um Hinweise, wo Du etwas zu ändern hast und um den Code für das anschließende Löschen der Quelldateien. Die Kill-Anweisung ist auch noch nicht scharf geschaltet.

Gruß
Aloys

Option Explicit

Sub Kopieren()
Dim sPfad As String 'Dateipfad
Dim LoL As Long 'letzte Zeile
Dim q As Long 'Zeilen# Quelldateien
Dim z As Long 'Zeilen# Zieldatei
Dim datei As String 'Name Quelldatei
Dim arr() 'Array der Dateinamen
Dim a As Long 'Index Array
Const sZeile As Long = 2 'Startzeile <---- ggf. Startzeile anpassen

' Initialisieren
sPfad = ThisWorkbook.Path & "\" 'Pfad der Quelldateien <---- ggf. Pfad anpassen
z = sZeile - 1 'Startzeile Zieldatei - 1

' Dateien einlesen und verarbeiten
Application.ScreenUpdating = False
datei = Dir(sPfad & "*.xls") ' Ersten Eintrag abrufen.
Do While datei <> "" ' Schleife beginnen.
If datei <> ThisWorkbook.Name Then
Workbooks.Open sPfad & datei
ThisWorkbook.Activate

'Dateinamen für das spätere Löschen in Array speichern
a = a + 1
ReDim Preserve arr(1 To a)
arr(a) = datei 'Dateinamen in Array sichern

'Kopieren Daten der aktuellen Quell-Datei nach Ziel-Datei
With Workbooks(datei).Worksheets("Tabelle1") '<---- ggf Blattname ändern
LoL = .Cells(.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Quelldaten
For q = sZeile To LoL
z = z + 1
.Range("A" & q & ":Z" & q).Copy ThisWorkbook.Worksheets("Tabelle1").Range("A" & z) '<---- Zeilenbegrenzung anpassen
Next q
End With

'Quelldatei wieder schließen
Workbooks(datei).Close savechanges:=False
End If
datei = Dir ' Nächsten Eintrag abrufen.
Loop
Application.ScreenUpdating = True

'Zieldatei speichern
ThisWorkbook.Save

' LÖschen aller Quell-Dateien
For a = 1 To UBound(arr)
'Kill sPfad & arr(a) '<--- nach dem Testen Hochkomma entfernen
Next a

'Abschluß-Nachricht
MsgBox "Dateien kopiert und gelöscht !", vbInformation
End Sub

skater57
11.07.2015, 17:23
Hallo,
und nochmals vielen Dank an Karin
ich verwende den Code von Karin und bin durch Ihren Hinweis darauf gekommen, den Code zu ergänzen, der vollständigkeithalber, so wie ich in benutze. Es spielt dabei keine Rolle wieviele Dateien in dem Ordner sind, Manko bei der Sache, wenn die Daten in den Dateien nicht die gleiche Strucktur haben. Man muss also beim speichern der Dateien entspechend aufpassen, es ist nicht abgesichert!

Sub mehrere_arbeitsmappen_oeffnen()
Dim strVerzeichnis As String
Dim strTyp As String
Dim strDateiname As String
Dim lngZeile As Long
strTyp = "*.xls"
Application.ScreenUpdating = False
strVerzeichnis = "f:\SAP\"
strDateiname = Dir(strVerzeichnis & strTyp)
lngZeile = 1
With ThisWorkbook.Worksheets("Tabelle1")
Do While strDateiname <> ""
Workbooks.Open Filename:=strVerzeichnis & strDateiname
'
Cells.Select
Selection.Copy
Application.DisplayAlerts = False 'ausschalten
ActiveWorkbook.Close True
'ans Ende springen
Windows("Gesamt.xlsm").Activate
ActiveSheet.Paste
ActiveCell.Offset(2, 5).Range("A1").Select
Application.DisplayAlerts = True 'einschalten
Selection.Copy
ActiveCell.Offset(9, -5).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, -1).Range("A1").Select
ActiveSheet.Paste
Selection.End(xlUp).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.FillDown
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
strDateiname = Dir
lngZeile = lngZeile + 1
Loop
End With
Application.ScreenUpdating = True
End Sub

Gruß Franz

Beverly
11.07.2015, 17:51
Hi Franz,

was dein Code zwischen dem Einfügen der Daten und dem Aufruf der nächsten Mappe machr, ist mir unklar, deshalb habe ich das mal weggelassen.
Wenn es darum geht, den benutzten Bereich der geöffneten Mappe (im für Beispiel für Tabelle10) immer fortlaufend in die erste freie Zeile in Spalte A zu kopieren, dann so:

Sub mehrere_arbeitsmappen_oeffnen()
Dim strVerzeichnis As String
Dim strTyp As String
Dim strDateiname As String
Dim lngErste As Long
strTyp = "*.xls"
Application.ScreenUpdating = False
strVerzeichnis = "f:\SAP\"
strDateiname = Dir(strVerzeichnis & strTyp)
With ThisWorkbook.Worksheets("Tabelle1")
Do While strDateiname <> ""
Workbooks.Open Filename:=strVerzeichnis & strDateiname
' erste freie Zeile in Spalte A ermitteln
lngErste = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
ActiveWorkbook.Worksheets("Tabelle10").UsedRange.Copy .Cells(lngErste, 1)
ActiveWorkbook.Close True
strDateiname = Dir
Loop
End With
Application.ScreenUpdating = True
End Sub


<hr width="20%" align="left"><img src="http://excel-inn.de/images/grusz.gif" height=35" align="left" alt="Grußformel"><a href="http://excel-inn.de/"><img border="0" src="http://excel-inn.de/images/logo1.gif" height=35" align="middle" alt="Beverly's Excel - Inn"></a>