Supportnet / Forum / Tabellenkalkulation
Zusammenfassung von Tabellen
Frage
Hallo
Ich habe in Tabelle 1, Tabelle2 etc jeweils zeilenweise Einträge. Nun möchte ich, dass diese automatisch in der Tabelle "Zusammenfassung" zusammengefasst werden. Wie mache ich das am besten, so dass keine Leerzeilen entstehen.
Danke für die Hilfe
Antwort 1 von Saarbauer
Hallo,
ist im Prinzip das gleiche Problem, lösung müsste bei dir eventuell angepasst werden.
https://supportnet.de/threads/1180045
Gruß
Helmut
ist im Prinzip das gleiche Problem, lösung müsste bei dir eventuell angepasst werden.
https://supportnet.de/threads/1180045
Gruß
Helmut
Antwort 2 von Fragenkatalog
Hallo Saarbauer,
hoff du kannst dich noch an mich errinnern. Du hast mir die lösung zu meinem Problem geliefert.
Ich hätte jetzt nur noch eine Frage.
Es sind ca. 190 Tabellen. die heißen Verbund_0201 und gehen bis Verbund_6586 aber dazwischen sind einige verbunde nicht da und da bringt er mir ne Fehlermeldung.
Kann man da irgendwas einbauen, dass es auch die Zahlen überspringt wenn die nicht da sind und er mag auch die 0 vor der zahl nicht. gibts da auch ne Lösung..
Danke
hoff du kannst dich noch an mich errinnern. Du hast mir die lösung zu meinem Problem geliefert.
Ich hätte jetzt nur noch eine Frage.
Es sind ca. 190 Tabellen. die heißen Verbund_0201 und gehen bis Verbund_6586 aber dazwischen sind einige verbunde nicht da und da bringt er mir ne Fehlermeldung.
Kann man da irgendwas einbauen, dass es auch die Zahlen überspringt wenn die nicht da sind und er mag auch die 0 vor der zahl nicht. gibts da auch ne Lösung..
Danke
Antwort 3 von nighty
hi all :)
hier noch eine variante der sheet erfassung,wobei das erste sheet der zusammenfassung dient :)
gruss nighty
Sub SheetErfassung()
Dim myWorksheet As Object
Dim myZeilen As Long
For Each myWorksheet In ThisWorkbook.Sheets
If myWorksheet.Index > 1 Then
For myZeilen = 1 To Sheets(myWorksheet.Index).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
Sheets(1).Cells(Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1, 1) = Sheets(myWorksheet.Index).Range("A" & myZeilen)
Next myZeilen
End If
Next
End Sub
hier noch eine variante der sheet erfassung,wobei das erste sheet der zusammenfassung dient :)
gruss nighty
Sub SheetErfassung()
Dim myWorksheet As Object
Dim myZeilen As Long
For Each myWorksheet In ThisWorkbook.Sheets
If myWorksheet.Index > 1 Then
For myZeilen = 1 To Sheets(myWorksheet.Index).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
Sheets(1).Cells(Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1, 1) = Sheets(myWorksheet.Index).Range("A" & myZeilen)
Next myZeilen
End If
Next
End Sub
Antwort 4 von Saarbauer
Hallo,
geht, man muss abfragen ob die Datei vorhanden ist. Sollte diese nicht da sein , Datei überspringen. Muss ich mal nachsehen wie die Befehle heissen, komm ich aber frühstens morgen dazu.
Ein anderer weg äwre die Dateien entsprechen umzubenennen, geht super mit Joe
http://lab1.de/Central/Software/Datei-Tools/Joe/
sieh mal da nach. Damit wäre es schneller erledigt
Gruß
Helmut
P.S falls du die orginaldateinamen später noch mal brauchst, mit Kopien arbeiten
geht, man muss abfragen ob die Datei vorhanden ist. Sollte diese nicht da sein , Datei überspringen. Muss ich mal nachsehen wie die Befehle heissen, komm ich aber frühstens morgen dazu.
Ein anderer weg äwre die Dateien entsprechen umzubenennen, geht super mit Joe
http://lab1.de/Central/Software/Datei-Tools/Joe/
sieh mal da nach. Damit wäre es schneller erledigt
Gruß
Helmut
P.S falls du die orginaldateinamen später noch mal brauchst, mit Kopien arbeiten
Antwort 5 von nighty
hi all :)
hier eine variante ohne namensbedeutung der mappen bei der gesamtmappenerfassung einer directory dessen dateien die endung xls besitzen :)))
gruss nighty
Option Explicit
Sub MappenErfassung()
Dim Mappen As Integer
With Application.FileSearch
.NewSearch
.LookIn = "C:\ExcelMappen"
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For Mappen = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(Mappen)
Workbooks(2).Sheets(1).Range("A1:C10").Copy _
Workbooks(1).Sheets(1).Range("A" & Workbooks(1).Sheets(1). _
UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 & ":C" & _
Workbooks(1).Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
Workbooks(2).Close
Next Mappen
End If
End With
End Sub
hier eine variante ohne namensbedeutung der mappen bei der gesamtmappenerfassung einer directory dessen dateien die endung xls besitzen :)))
gruss nighty
Option Explicit
Sub MappenErfassung()
Dim Mappen As Integer
With Application.FileSearch
.NewSearch
.LookIn = "C:\ExcelMappen"
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For Mappen = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(Mappen)
Workbooks(2).Sheets(1).Range("A1:C10").Copy _
Workbooks(1).Sheets(1).Range("A" & Workbooks(1).Sheets(1). _
UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 & ":C" & _
Workbooks(1).Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
Workbooks(2).Close
Next Mappen
End If
End With
End Sub
Antwort 6 von Fragenkatalog
Hätte dann noch eine Frage..
Wie mache ich es wenn die Namen der Tabellen unterschiedlich sind? Kann ich da eine Liste einspeicher und immer wenn ich die liste ändere, hlot er sich die Daten aus den Tabellen.
Wie mache ich es wenn die Namen der Tabellen unterschiedlich sind? Kann ich da eine Liste einspeicher und immer wenn ich die liste ändere, hlot er sich die Daten aus den Tabellen.
Antwort 7 von Fragenkatalog
Hallo nighty,
ich habe jetzt mal deinen lösungsweg anwewandt.
Das einige Problem ist, dass meine Tabellen unterschiedlich lang sind also von a bis v und von 4 bis x.
wie muss dann die formel heißen?
wenn ich nicht nur bis 10 copieren will sonder bis zur letzten zeile?
Danke
ich habe jetzt mal deinen lösungsweg anwewandt.
Das einige Problem ist, dass meine Tabellen unterschiedlich lang sind also von a bis v und von 4 bis x.
wie muss dann die formel heißen?
wenn ich nicht nur bis 10 copieren will sonder bis zur letzten zeile?
Danke
Antwort 8 von Saarbauer
Hallo,
so abändern
Option Explicit
Sub MappenErfassung()
Dim Mappen As Integer
With Application.FileSearch
.NewSearch
.LookIn = "C:\ExcelMappen"
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For Mappen = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(Mappen)
Letztezeile = Workbooks(2).Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row )
Workbooks(2).Sheets(1).Range("A1:" & Letztezeile).Copy _
Workbooks(1).Sheets(1).Range("A" & Workbooks(1).Sheets(1). _
UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 & ":C" & _
Workbooks(1).Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
Workbooks(2).Close
Next Mappen
End If
End With
End Sub
und Wert in Zeile
Workbooks(2).Sheets(1).Range("A1:10").Copy _
löschen
Gruß
Helmut
so abändern
Option Explicit
Sub MappenErfassung()
Dim Mappen As Integer
With Application.FileSearch
.NewSearch
.LookIn = "C:\ExcelMappen"
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For Mappen = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(Mappen)
Letztezeile = Workbooks(2).Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row )
Workbooks(2).Sheets(1).Range("A1:" & Letztezeile).Copy _
Workbooks(1).Sheets(1).Range("A" & Workbooks(1).Sheets(1). _
UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 & ":C" & _
Workbooks(1).Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
Workbooks(2).Close
Next Mappen
End If
End With
End Sub
und Wert in Zeile
Workbooks(2).Sheets(1).Range("A1:10").Copy _
löschen
Gruß
Helmut
Antwort 9 von Fragenkatalog
danke Helmut.
jetzt ist mir nur aufgefallen, dass das Programm ddas erste Datenblatt copiert. gibt es auch ne möglichkeit immer das gleiche datenblatt Sicherheiten kopiern zu lassen. Falls es vorhanden ist und wenn nicht dann überspringen..
Danke dir
jetzt ist mir nur aufgefallen, dass das Programm ddas erste Datenblatt copiert. gibt es auch ne möglichkeit immer das gleiche datenblatt Sicherheiten kopiern zu lassen. Falls es vorhanden ist und wenn nicht dann überspringen..
Danke dir
Antwort 10 von Fragenkatalog
Option Explicit
Sub MappenErfassung()
Dim Mappen As Integer
Dim Letztezeile As Integer
With Application.FileSearch
.NewSearch
.LookIn = "Y:\Eigene Dateien\Test"
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For Mappen = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(Mappen)
Letztezeile = Workbooks(2).Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
Workbooks(2).Sheets(1).Range("A4:" & Letztezeile).Copy _
Workbooks(1).Sheets(1).Range("A" & Workbooks(1).Sheets(1). _
UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 & ":C" & _
Workbooks(1).Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
Workbooks(2).Close
Next Mappen
End If
End With
End Sub
Was ist da der Fehler. der Bringt mir ein " anwendungs- oder objektdefinierter Fehler"
Wenn man so wie es da steht noch definieren könnte, dass er in das Blatt "sicherheiten" geht und da raus kopiert, außer gleich das erste dann wäre mir sehr geholfen und die Dateine überspringen, die dieses Blatt nicht haben.
Großes Lob an euch bis jetzt.
Danke
Sub MappenErfassung()
Dim Mappen As Integer
Dim Letztezeile As Integer
With Application.FileSearch
.NewSearch
.LookIn = "Y:\Eigene Dateien\Test"
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For Mappen = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(Mappen)
Letztezeile = Workbooks(2).Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
Workbooks(2).Sheets(1).Range("A4:" & Letztezeile).Copy _
Workbooks(1).Sheets(1).Range("A" & Workbooks(1).Sheets(1). _
UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 & ":C" & _
Workbooks(1).Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
Workbooks(2).Close
Next Mappen
End If
End With
End Sub
Was ist da der Fehler. der Bringt mir ein " anwendungs- oder objektdefinierter Fehler"
Wenn man so wie es da steht noch definieren könnte, dass er in das Blatt "sicherheiten" geht und da raus kopiert, außer gleich das erste dann wäre mir sehr geholfen und die Dateine überspringen, die dieses Blatt nicht haben.
Großes Lob an euch bis jetzt.
Danke
Antwort 11 von Saarbauer
Hallo,
nicht vergessen, aber heute keine Lust mehr. Bin gerade erst nach Hause gekommen
Gruß
Helmut
nicht vergessen, aber heute keine Lust mehr. Bin gerade erst nach Hause gekommen
Gruß
Helmut
Antwort 12 von Saarbauer
Hallo,
gehe mal in den "Visalbasiceditor" Klicke in das programm und gehe mit "F8" es schrittweise durch. In welcher Zeile kommt die Fehlermeldung?
In allen Zeilen mit
Workbooks(2).Sheets("Sicherheiten")
ist anstelle der 1 das Wort "Sicherheiten" einzuführen
Achtung funktioniert nur wenn "Sicherheiten" immer gleich geschrieben ist
Gruß
Helmut
gehe mal in den "Visalbasiceditor" Klicke in das programm und gehe mit "F8" es schrittweise durch. In welcher Zeile kommt die Fehlermeldung?
In allen Zeilen mit
Zitat:
Workbooks(2).Sheets( 1)
Workbooks(2).Sheets( 1)
Workbooks(2).Sheets("Sicherheiten")
ist anstelle der 1 das Wort "Sicherheiten" einzuführen
Achtung funktioniert nur wenn "Sicherheiten" immer gleich geschrieben ist
Gruß
Helmut
Antwort 13 von nighty
hi ihr :))
vielleicht so :)
gruss nighty
Option Explicit
Sub MappenErfassung()
On Error GoTo fehler
Dim Mappen As Integer
Dim Letztezeile As Integer
With Application.FileSearch
.NewSearch
.LookIn = "Y:\Eigene Dateien\Test"
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For Mappen = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(Mappen)
Letztezeile = Workbooks(2).Sheets("Sicherheiten").UsedRange.SpecialCells(xlCellTypeLastCell).Row
Letztespalte = Workbooks(2).Sheets("Sicherheiten").UsedRange.SpecialCells(xlCellTypeLastCell).Column
If Err <> 9 Then
Workbooks(2).Sheets("Sicherheiten").Range("A4:" & Chr$(65 + Letztespalte) & Letztezeile).Copy _
Workbooks(1).Sheets(1).Range("A" & Workbooks(1).Sheets(1). _
UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 & ":C" & _
Workbooks(1).Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
End If
Workbooks(2).Close
Next Mappen
End If
End With
End
fehler:
If Err = 9 Then Resume Next
End Sub
vielleicht so :)
gruss nighty
Option Explicit
Sub MappenErfassung()
On Error GoTo fehler
Dim Mappen As Integer
Dim Letztezeile As Integer
With Application.FileSearch
.NewSearch
.LookIn = "Y:\Eigene Dateien\Test"
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For Mappen = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(Mappen)
Letztezeile = Workbooks(2).Sheets("Sicherheiten").UsedRange.SpecialCells(xlCellTypeLastCell).Row
Letztespalte = Workbooks(2).Sheets("Sicherheiten").UsedRange.SpecialCells(xlCellTypeLastCell).Column
If Err <> 9 Then
Workbooks(2).Sheets("Sicherheiten").Range("A4:" & Chr$(65 + Letztespalte) & Letztezeile).Copy _
Workbooks(1).Sheets(1).Range("A" & Workbooks(1).Sheets(1). _
UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 & ":C" & _
Workbooks(1).Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
End If
Workbooks(2).Close
Next Mappen
End If
End With
End
fehler:
If Err = 9 Then Resume Next
End Sub
Antwort 14 von Fragenkatalog
Danke an euch alle.
Werde eure Vorschläge mal ausprobieren.
Wünsche euch ein schönes Wochenende.
Werde eure Vorschläge mal ausprobieren.
Wünsche euch ein schönes Wochenende.