Code funktioniert nur mit F8 richtig
16.10.2021 10:28:18
Sarah
ich bin mehr als ratlos und komm einfach nicht auf die Lösung.
Für das Verständnis, die Datei in der dieser Code läuft, ist eine Art Sammeldatei.
Der Schichtreport für eine Woche besteht aus, bis zu 3 Dateien (3Schichten) mit bis zu 6 Tabellenblättern(Montag bis Samstag) ,diese haben alle den selben Aufbau.
Auch meine Datei ist gleich aufgebaut, nur das ich alle 3 Schichten und (beschriebene) Wochentage in einem Tabellenblatt zusammenfassen möchte.
Mein Problem stellt sich folgendermaßen dar --> durch einen Button in meiner Mappe wird der Code ausgeführt und läuft auch durch, doch er kopiert mir teilweise weniger und lässt Zeilen aus und manchmal auch die Zeile A9:O doch diese brauch ich nicht. Ich will auch nicht das er mir leere Zeilen einfügt, macht er z.B. an einem Samstag wenn nichts in Zeile A10:O drin steht.
Wenn ich den Code jedoch mit F8 Stück für Stück durchgehe und mir jedes Tabellenblatt anschaue welchen Bereich er da kopiert, macht er genau das was er soll!
Und das ist für mich einfach nicht nachvollziehbar :(
Ich hoffe sehr das mir einer von euch helfen kann :)
MfG Sarah
Hier der Code:
Private Sub cmB_Datah_einfuegen_Click()
Call Mehrere_Dateien_auswählen
End Sub
Sub Mehrere_Dateien_auswählen()
Dim arrDateien As Variant
Dim wbQuelle As Workbook
Dim LetzteZeileZiel As Long
Dim cntDatei As Long
Dim sh As Worksheet
' Screenupdating und PopUps deaktivieren
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Benutzer Dateien auswählenlassen
ChDir "\\europe.(xxx)Schichtreport\Archiv\2021"
arrDateien = Application.GetOpenFilename(filefilter:="Excel-Dateien (*.xls*),*.xls*", MultiSelect:=True)
LetzteZeileZiel = ThisWorkbook.Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row
' Wurde eine Datei ausgewählt?
If IsArray(arrDateien) Then
' Schleife über alle Dateien
For cntDatei = 1 To UBound(arrDateien)
'Aktuelle Arbeitsmappe öffnen
Set wbQuelle = Workbooks.Open(Filename:=arrDateien(cntDatei), UpdateLinks:=False, ReadOnly:=True)
' Schleife über alle Tabellenblätter
For Each sh In wbQuelle.Sheets
If sh.Name "Daten" Then
' Daten kopieren und einfügen
sh.Range("A10:O" & Cells(Rows.Count, 1).End(xlUp).Row).Copy
ThisWorkbook.Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
End If
Next sh
' Arbeitsmappe schließen
wbQuelle.Close SaveChanges:=False
Next cntDatei
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub