Sub Alle_xls_öffnen_und_kopieren()

Question

Hallo zusammen, ich habe ein Problem das der Code nicht das macht was er soll.......
Er überschreibt mir immer in der Zieldatei die schon vorhanden Zeilen und fügt die nicht unten an der ersten freien Zeile ein!! .
Kann mir da einer Helfen... Danke im voraus.

Answer 1

Das ist der Code.




Sub Alle_xls_öffnen_und_kopieren()
Application.ScreenUpdating = False
Dim Dateiname As String
Dim Pfad As String
Dim Zieldatei As String
Dim firstRow As Long
Dim lastRow As Long
Dim Zieleblatt As String
Dim lastRowNew As Integer
'Alles im aktiven Blatt löschen
'Range("A2:Z65536").ClearContents
'Name der Datei, in das kopiert werden soll,
'wird automatisch aus dem Dateinamen ausgelesen
Zieldatei = ActiveWorkbook.Name
'Name des tabellenblattes, in das kopiert werden soll
'wird automatisch aus aktuellen Tabellenblattnamen ausgelesen
Zieleblatt = ActiveSheet.Name
'Pfad, in dem sich die Dateien, die ausgelesen werden sollen, befinden
Pfad = "P:\QM-MP\QM-MP\060_Q-After-Sales-Prozesse\03_AS-Checks\05_ASP- Check\Baureihe A205\16_Interne Verwendung QM\"
Dateiname = Dir(Pfad & "*.xlsx")
'Schleife zum Öffnen aller Exceldateien im Pfad aus der Variablen "Pfad" den Pfad mit * ersetzen wenn alle dateienn die abgefragt werden sollen in einem ordner liegen!!!!
Do While Dateiname <> ""
'Datei wird unsichtbar geöffnet
GetObject (Pfad & Dateiname)
'erste freie Zeile in Zieldatei wird ermittelt und in Variable "firstRow" geschrieben
firstRow = Workbooks(Zieldatei).Sheets(1).Range("z65536").End(xlUp).Offset(1, 0).Row
'letzte beschriebene Zeile in Quelldatei wird ermittelt und in Variable "lastRow" geschrieben
lastRow = Workbooks(Dateiname).Sheets(1).Range("z65536").End(xlUp).Row
'Daten werden aus dem Bereich A6:Z65000 kopiert und in Zieldatei in ersten freien Zeile eingefügt
Workbooks(Dateiname).Sheets(1).Range("A6:Z65536" & lastRow).Copy _
Workbooks(Zieldatei).Sheets(Zieleblatt).Cells(firstRow, 1)
'Quelldatei wird wieder geschlossen
Workbooks(Dateiname).Close False
Dateiname = Dir
'letzte beschriebene Zeile in Quelldatei in Spalte z wird ermittelt und in Variable "lastRow" geschrieben
lastRowNew = Workbooks(Zieldatei).Sheets(Zieleblatt).Range("z65536").End(xlUp).Row
'Summe aus Spalte z eintragen
Workbooks(Zieldatei).Sheets(Zieleblatt).Cells(lastRowNew + 1, 8) = _
Application.WorksheetFunction.Sum(Workbooks(Zieldatei).Sheets(Zieleblatt).Range("z" & firstRow & ":Z" & lastRowNew))
'Nächste Datei wird geöffnet
Loop
End Sub

Answer 2

Hi MB100 :-)

Probier mal ^^

Gruss Nighty

Der Pad ist in der dritten Zeile anzupassen!

Sub DateienLesen()
Call EventsOff
Dim DateiName As String
Dateipfad = "D:\Temp\"
DateiName = Dir(Dateipfad & "*.xlsx")
Do While DateiName <> ""
Workbooks.Open Filename:=Dateipfad & DateiName
ActiveSheet.UsedRange.Copy ThisWorkbook.ActiveSheet.Cells(ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
Workbooks(DateiName).Close
DateiName = Dir
Loop
Call EventsOn
End Sub

Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub

Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Answer 3

hallo, Danke erstmal aber ich bekomme eine Fehlermeldung :
--> Fehler beim Kompilieren:
Nach EndSUB, END Function oder ENd Property können nur Kommentare stehen..

Answer 4

hi MB100 :-)

Alle drei Module gehören in ein Allgemeines Modul!

Einzufüfen
Alt+F11/Projektexplorer/Allgemeines Modul

Kopieren/Einfügen ist sorgfälltig zu Selectieren!

Gruss Nighty

Answer 5

Hi MB100 ^^

Pfad ist nun angepassr und es sollte Problemlos erstmal laufen!

Gruss Nighty

Sub DateienLesen()
Call EventsOff
Dim DateiName As String
Dim Dateipfad As String
Dateipfad ="P:\QM-MP\QM-MP\060_Q-After-Sales-Prozesse\03_AS-Checks\05_ASP- Check\Baureihe A205\16_Interne Verwendung QM\"
DateiName = Dir(Dateipfad & "*.xlsx")
Do While DateiName <> ""
Workbooks.Open Filename:=Dateipfad & DateiName
ActiveSheet.UsedRange.Copy ThisWorkbook.ActiveSheet.Cells(ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
Workbooks(DateiName).Close
DateiName = Dir
Loop
Call EventsOn
End Sub

Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub

Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Answer 6

ähi,
ich flipp noch aus jetzt bekomme ich ein Fenster mit rotem Kreuz und 400....

Answer 7

hi MB100 ^^

Geschützte Bereiche oder auch Verbundene Zellen sind nicht berücksichtigt!

Gruss Nighty

Answer 8

List dein VBA auch erst ab der 6 Zeile??

Answer 9

Hi MB100 ^^

Es wir der gesammte genutzte Bereich kopiert!
Sollte erst ab der 6 Zeile kopiertwerden ändere ich das nachher!
Muss jetzt zur Arbeit und schaue Nachmittags nochmal darüber!

Gruss Nighty

Answer 10

Hi MB100 .-)

Ging ja schnell :-)
Ab der 6 Zeile bis zum Ende des genutzten Bereiches!

Gruss Nighty

Sub DateienLesen()
Call EventsOff
Dim DateiName As String
Dim Dateipfad As String
Dateipfad = "P:\QM-MP\QM-MP\060_Q-After-Sales-Prozesse\03_AS-Checks\05_ASP- Check\Baureihe A205\16_Interne Verwendung QM\"
DateiName = Dir(Dateipfad & "*.xlsx")
Do While DateiName <> ""
Workbooks.Open Filename:=Dateipfad & DateiName
ActiveSheet.Range(Cells(6, 1), Cells(ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row, ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column)).Copy ThisWorkbook.ActiveSheet.Cells(ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
Workbooks(DateiName).Close
DateiName = Dir
Loop
Call EventsOn
End Sub

Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub

Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub