Daten auslesen und in extra Tabelle Speichen

Guten Abend
Brauch wieder mal Hilfe und Rat.
Ich möchte Daten aus mehreren Tabellen sammeln. Da ich eine Strees-/Arbeitsbelastung be-/auswerten soll.
Durch Forumsbeiträge bin ich auf einen Code gestoßen, der das macht. Also in die Mappe reinschauen, die Daten kopiert und sie dann in die Auswertetabelle einträgt. Um den Code für mein Vorhaben anzupassen fehlen mir leider die nötigen Kenntnisse.
Der Code macht zwischen den Daten der abgefragten Mappe immer 40 leere Zeilen. Außerdem macht der Code folgendes, wenn ich die Daten aus der Tabelle gelöscht habe und eine neue Datenabfrage mache, schreibt dieser die nun ausgelesenen Daten nicht wieder ab Zeile 1 sondern in die Zeile welche die letzte leere Zeile der vorigen Speicherung war.
Bei meinen Versuchen habe ich mit 5 Mappen a 25-30 Zeilen getestet. Da es aber 50 Mappen werden sind 40 Leerzeilen doch schon für mich eine Menge was an Platz weg ist.
1. Was muss ich verändern/machen damit die 40 leeren Zeilen nicht mehr zwischen den datensätzen sind?
2. Was ist zu verändern, das der Code bei leerem Tabellenblatt ab der Zeile 2 begint einzutragen bzw wenn schon Daten drin stehen ab der letzten leeren Zeile weiter einträgt?
Hier noch die gebastelte Testtabelle
https://www.herber.de/bbs/user/119684.xlsm
Achso, die Tabellen der Kollegen sind alle gleich aufgebaut
Zeile 1 sind Überschriften
Spalte
A: SpeicherDatum
B: SpeicherZeit
C: Arbeitsaufwand
D: Gund
E: Butto (welcher gedrückt wurde)
F: Arbeitsbereich
G: wer hat gespeichert
Hoffe ich hab's verständlich erklärt und es kann mir eine/r dabei helfen
Oder es gibt andere vielleicht bessere Lösungen
freundlicher Gruß
Ha-Pe

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub CommandButton21_Click() Dim strDateiname As String Dim wksZiel As Worksheet, wkbQuelle As Workbook, wksQuelle As Worksheet Dim loLetzte1 As Long Dim loLetzte2 As Long Dim inLetzte As Integer Application.ScreenUpdating = False strDateiname = Dir(ThisWorkbook.Path & "\*.xlsm") Set wksZiel = ThisWorkbook.Worksheets("Tabelle1") Do While strDateiname "" If strDateiname ThisWorkbook.Name Then Set wkbQuelle = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & strDateiname) Set wksQuelle = wkbQuelle.Worksheets(2) loLetzte1 = wksZiel.Cells(wksZiel.Rows.Count, 1).End(xlUp).Row + 1 'wenn in der Zieltabelle in Zeile 1 immer Daten/Überschriften 'vorhanden sind, dann brauchst du die folgende Zeile nicht If wksZiel.Cells(2, 1) = "" Then loLetzteZiel = 2 With wksQuelle loLetzte2 = .Cells(.Rows.Count, 1).End(xlUp).Row inLetzte = .Cells(1, .Columns.Count).End(xlToLeft).Column .Range(.Cells(2, 1), .Cells(loLetzte2, inLetzte)).Copy _ Destination:=wksZiel.Cells(loLetzte1, 1) End With wkbQuelle.Close True End If strDateiname = Dir Loop Set wkbQuelle = Nothing: Set wksQuelle = Nothing: Set wksZiel = Nothing Application.ScreenUpdating = True End Sub

Hallo Ha-Pe,
da würde ich einfach als erstes die Daten im Zielblatt leeren, dann kannst du nie doppelte Datensätze im Zielblatt haben.
Wenn du die Daten während dem Makrolauf, immer nachdem sie kopiert worden sind gleich löschen/leeren würdest, dann hast du das Problem, dass deine Quelldaten weg sind. Wenn jetzt, aus irgendwelchen Gründen, was schief läuft, dann sind deine Quelldaten weg.
Eine weitere Möglichkeit wäre (die sichere Vatiante) die Daten aus den Quellblättern zu holen, ins Zielblatt zu kopieren, das Zielblatt zu speichern und danach die Daten aus den Quellblättern zu löschen. Dann müsste man aber nochmal in einer Schleife über alle Quellblätter laufen und die alle nochmal öffnen, Daten leeren und wieder schließen. Da würde ich aber drauf verzichten, das ständige öffnen und schließen der Dateien ist nicht gerade besonders schnell.
Der Fehler mit der nicht deklarierten Variablen ist behoben - war ein Schreibfehler.

Option Explicit
Private Sub CommandButton21_Click()
Dim strDateiname As String
Dim wksZiel As Worksheet, wkbQuelle As Workbook, wksQuelle As Worksheet
Dim loLetzte1 As Long
Dim loSpalte As Long
Dim loLetzte2 As Long
Dim inLetzte As Integer
Application.ScreenUpdating = False
strDateiname = Dir(ThisWorkbook.Path & "\*.xlsm")
Set wksZiel = ThisWorkbook.Worksheets("Tabelle1")
'Daten im Zielblatt leeren
With wksZiel
loLetzte1 = .Cells(.Rows.Count, 1).End(xlUp).Row
loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column
If loLetzte1 > 2 then
.Range(.Cells(2, 1), .Cells(loLetzte1, loSpalte)).ClearContents
End If
End With
Do While strDateiname  ""
If strDateiname  ThisWorkbook.Name Then
Set wkbQuelle = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & strDateiname)
Set wksQuelle = wkbQuelle.Worksheets(2)
loLetzte1 = wksZiel.Cells(wksZiel.Rows.Count, 1).End(xlUp).Row + 1
'wenn in der Zieltabelle in Zeile 1 immer Daten/Überschriften
'vorhanden sind, dann brauchst du die folgende Zeile nicht
If wksZiel.Cells(2, 1) = "" Then loLetzte1 = 2
With wksQuelle
loLetzte2 = .Cells(.Rows.Count, 1).End(xlUp).Row
inLetzte = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, 1), .Cells(loLetzte2, inLetzte)).Copy _
Destination:=wksZiel.Cells(loLetzte1, 1)
End With
wkbQuelle.Close True
End If
strDateiname = Dir
Loop
Set wkbQuelle = Nothing: Set wksQuelle = Nothing: Set wksZiel = Nothing
Application.ScreenUpdating = True
End Sub

Gruß Werner

Option Explicit Private Sub CommandButton21_Click() Dim strDateiname As String Dim wksZiel As Worksheet, wkbQuelle As Workbook, wksQuelle As Worksheet Dim loLetzte1 As Long Dim loSpalte As Long Dim loLetzte2 As Long Dim loLetzte As Long Dim loZähler As Long Application.ScreenUpdating = False strDateiname = Dir(ThisWorkbook.Path & "\*.xlsm") Set wksZiel = ThisWorkbook.Worksheets("Tabelle1") 'Daten im Zielblatt leeren With wksZiel loLetzte1 = .Cells(.Rows.Count, 1).End(xlUp).Row loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column .Range(.Cells(2, 1), .Cells(loLetzte1, loSpalte)).ClearContents End With Do While strDateiname "" If strDateiname ThisWorkbook.Name Then Set wkbQuelle = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & strDateiname) Set wksQuelle = wkbQuelle.Worksheets(2) loLetzte1 = wksZiel.Cells(wksZiel.Rows.Count, 1).End(xlUp).Row + 1 'wenn in der Zieltabelle in Zeile 1 immer Daten/Überschriften 'vorhanden sind, dann brauchst du die folgende Zeile nicht If wksZiel.Cells(2, 1) = "" Then loLetzte1 = 2 With wksQuelle loLetzte2 = .Cells(.Rows.Count, 1).End(xlUp).Row loLetzte = .Cells(1, .Columns.Count).End(xlToLeft).Column 'intLetzte - 1 = Spalte mit den Usernamen wird nicht mitkopiert .Range(.Cells(2, 1), .Cells(loLetzte2, loLetzte - 1)).Copy _ Destination:=wksZiel.Cells(loLetzte1, 1) loZähler = loZähler + 1 End With wkbQuelle.Close True End If strDateiname = Dir Loop 'Anzahl Schleifendurchläufe in Zelle schreiben wksZiel.Cells(2, loSpalte) = loZähler Set wkbQuelle = Nothing: Set wksQuelle = Nothing: Set wksZiel = Nothing Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

Daten auslesen und in extra Tabelle Speichen

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Daten auslesen und in extra Tabelle Speichen

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread