Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1676to1680
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Zellenbereich mehrere Tabellenblätter kopieren

Zellenbereich mehrere Tabellenblätter kopieren
27.02.2019 11:42:50
Ro
Hallo Zusammen:
ich weiß es nicht ob Makro eine solche Funktion leisten kann.
Ich habe eine Exceldatei mit Tabellenblätter " Auswertungen", "Tabelle 1", "Tabelle 2" "Tabelle 3" "Berechnungsblatt" und Eingabe".
Kann später auch kommen, dass neue Tabellenblätter wie "Tabelle 4" usw. erstellt werden.
Die Tabelle 1 bis Tabelle 3 usw. sind gleich aufgebaut. In Spalte A "Teile" enthält die Bezeichnung der bewerteten Teilen. In Spalte B1 bis I1 ist das Datum eingetragen wann die Bewertung durchgeführt wurde. Ab Zellenbereich B2:I2 sind die Bewertungen pro Teile eingetragen. Diese kann so lange sein, bis in Spalte A keine Teile mehr eingetragen ist. Von Tabellen "Berechnungsblatt" und Eingabe" muss nichts kopiert werden.
Makro soll diese Zellebereich also alle Bewertungen pro Tabellenblatt kopieren und diese in Tabelle "Auswertungen" in entsprechenden Datum nacheinander zuordnen.
Z.B. in Tabelle 1 bis 4 Spalte B "10.11.2016" die Bewertungen kopieren und in die Tabelle Auswertung die Spalte 10.11.2016" suchen und dort untereinander einfügen. Das gleich auch z.B. für Spalte C "06.04.2017" usw.
Datum ist variable und kann es sein dass "10.11.2016" nur in Tabellen 1 und 2 in Spalten B befindet und in Tabelle 3 in Spalte B befindet sich anderes Datum wie "11.11.2016".
Geht es? Würde mich mega freuen, wenn jemand mir eine Lösung dazu gibt.
Beispieltabelle ist unter:
https://www.herber.de/bbs/user/127968.xlsx

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zellenbereich mehrere Tabellenblätter kopieren
27.02.2019 13:41:47
Werner
Hallo,
so:
Option Explicit
Public Sub Sammeln()
Dim loLetzteQ As Long, loSpalte As Long, loLetzteZ As Long
Dim i As Long, ws As Worksheet, raFund As Range
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case "Auswertung", "Berechnungsblatt", "Eingabe"
Case Else
With ws
loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 2 To loSpalte
Set raFund = Worksheets("Berechnungsblatt").Rows(1).Find(what:=.Cells(1, i), _
_
LookIn:=xlFormulas, lookat:=xlWhole)
If Not raFund Is Nothing Then
loLetzteQ = .Cells(.Rows.Count, i).End(xlUp).Row
.Range(.Cells(2, i), .Cells(loLetzteQ, i)).Copy
With Worksheets("Berechnungsblatt")
loLetzteZ = .Cells(.Rows.Count, raFund.Column).End(xlUp).Offset(1). _
Row
.Cells(loLetzteZ, raFund.Column).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End With
End If
Next i
End With
End Select
Next ws
Set raFund = Nothing
End Sub
Gruß Werner
Anzeige
nochmal ohne die Zeilenumbrüche...
27.02.2019 13:43:31
Werner
Hallo,
...die werden von der Forensoftware eingefügt.
Option Explicit
Public Sub Sammeln()
Dim loLetzteQ As Long, loSpalte As Long, loLetzteZ As Long
Dim i As Long, ws As Worksheet, raFund As Range
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case "Auswertung", "Berechnungsblatt", "Eingabe"
Case Else
With ws
loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 2 To loSpalte
Set raFund = Worksheets("Berechnungsblatt").Rows(1).Find(what:= _
.Cells(1, i), LookIn:=xlFormulas, lookat:=xlWhole)
If Not raFund Is Nothing Then
loLetzteQ = .Cells(.Rows.Count, i).End(xlUp).Row
.Range(.Cells(2, i), .Cells(loLetzteQ, i)).Copy
With Worksheets("Berechnungsblatt")
loLetzteZ = .Cells(.Rows.Count, raFund.Column). _
End(xlUp).Offset(1).Row
.Cells(loLetzteZ, raFund.Column).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End With
End If
Next i
End With
End Select
Next ws
Set raFund = Nothing
End Sub
Gruß Werner
Anzeige
AW: nochmal ohne die Zeilenumbrüche...
27.02.2019 14:00:39
Ro
Unglaublich...ein Traum... Es funktioniert sehr gut...
Noch ne frage: Kann ich die Spaltennamen alle Datum von den Tabellenblätter, aus denen die Werte übernommen werden, ermitteln und in die gesamten Tabelle einfügen, ohne das Datum 2 mal eingetragen werden. z.B. in Tabelle 1 sind : 12.12.2018, 13.12.2018,14.12.2018 und in Tabelle 2 sind 12.12.2018, 13.12.2018, 15.12.2018 usw.und sollte in Tabelle "Berechnung" A1: 12.12.2018, A2:13.12.2018 A3:14.12.2018
A4: 15.12.2018 usw. bis zu letzten ermittelte Werte..
Das wäre prima! Danke dir im Vorfeld. Bist mein Held heute!
AW: nochmal ohne die Zeilenumbrüche...
27.02.2019 14:30:17
Werner
Hallo,
sorry, aber im Moment verstehe ich nicht was du meinst. Lad doch nochmal eine Beispielmappe hoch. Im Berechnungsblatt trägst du ein paar Datensätze ein, so wie dein Wunschergebnis aussehen soll.
Gruß Werner
Anzeige
AW: nochmal ohne die Zeilenumbrüche...
27.02.2019 15:03:39
Ro
Hallo
hier die Tabelle
im Blatt "Ergebnis" habe ich dargestellt, wie das Ergebnis von Makro aussehen soll.
https://www.herber.de/bbs/user/127975.xlsx
Danke für deine Bemühung.
Ro
AW: nochmal ohne die Zeilenumbrüche...
27.02.2019 16:15:04
Werner
Hallo,
hier deine Mappe zurück. Hab das Makro jetzt noch umgeschreiben, dass die Leerzellen entfernt werden.
https://www.herber.de/bbs/user/127977.xlsm
Gruß Werner
AW: nochmal ohne die Zeilenumbrüche...
28.02.2019 11:32:10
Ro
Vielen Vielen Dank...Es hat super funktioniert :)
Du bist experte!
Gerne u. Danke für die Rückmeldung. o.w.T.
28.02.2019 12:23:19
Werner
AW: Gerne u. Danke für die Rückmeldung. o.w.T.
28.02.2019 15:16:24
Robert
Hey Werner,
ich muss mich nochmal bei dir melden.
Die zu ermittelnden Datum bzw. die zu kopierenden Werte befinden sich nicht mehr in Zeile 1 (DATUM) bzw. ab 2 (BEWERTUNG) sondern in Zeile 21 (DATUM) bzw. ab Zeile 22 (Bewertung).
Ich versuche in Code die Zeilennummer zu ändern, aber klappt es nicht. Irgendwas mach ich falsch.
Kannst du mir bitte weiter helfen? Danke dir im Voraus.
hier nochmal die Datei, wie sie aussehen sollte.
https://www.herber.de/bbs/user/127996.xlsm
Anzeige
AW: Gerne u. Danke für die Rückmeldung. o.w.T.
28.02.2019 16:31:15
Werner
Hallo Robert,
sollte doch nicht so schwer sein.
Option Explicit
Public Sub Sammeln()
Dim loSpalteQ As Long, loSpalte As Long, loSpalteZ As Long
Dim loLetzteQ As Long, loLetzteZ As Long, i As Long, n As Long
Dim ws As Worksheet, raFund As Range
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case "Berechnungsblatt", "Auswertung", "Eingabe"
Case Else
With ws
loSpalte = .Cells(21, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(21, 9), .Cells(21, loSpalte)).Copy
With Worksheets("Berechnungsblatt")
loLetzteZ = .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Row
If .Cells(1, 1) = "" Then loLetzteZ = 1
.Cells(loLetzteZ, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
Application.CutCopyMode = False
End With
End With
End Select
Next ws
With Worksheets("Berechnungsblatt")
.Columns(1).RemoveDuplicates Columns:=1, Header:=xlNo
loLetzteZ = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.Cells(1, 1), .Cells(loLetzteZ, 1)).Copy
.Cells(1, 2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
Application.CutCopyMode = False
.Columns(1).Delete
End With
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case "Berechnungsblatt", "Auswertung", "Eingabe"
Case Else
With ws
loSpalte = .Cells(21, .Columns.Count).End(xlToLeft).Column
For i = 9 To loSpalte
Set raFund = Worksheets("Berechnungsblatt").Rows(1).Find(what:= _
.Cells(21, i), LookIn:=xlFormulas, lookat:=xlWhole)
If Not raFund Is Nothing Then
loLetzteQ = .Cells(.Rows.Count, i).End(xlUp).Row
.Range(.Cells(22, i), .Cells(loLetzteQ, i)).Copy
With Worksheets("Berechnungsblatt")
loLetzteZ = .Cells(.Rows.Count, raFund.Column). _
End(xlUp).Offset(1).Row
.Cells(loLetzteZ, raFund.Column).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End With
End If
Next i
End With
End Select
Next ws
With Worksheets("Berechnungsblatt")
loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 1 To loSpalte
loLetzteZ = .Cells(.Rows.Count, i).End(xlUp).Row
For n = loLetzteZ To 2 Step -1
If .Cells(n, i) = "" Then .Cells(n, i).Delete
Next n
Next i
.Range(.Cells(1, 1), .Cells(1, loSpalte)).EntireColumn.ColumnWidth = 5
End With
Set raFund = Nothing
End Sub
Gruß Werner
Anzeige
AW: Gerne u. Danke für die Rückmeldung. o.w.T.
01.03.2019 13:29:51
Robert
Hallo Werner,,,vielen dank...
Da ich mehr ca. 80 Tabellenblätter in der Datei habe, dauert die makro mehr als 3 stunde...:((
hast eine Idee wie kann mann es lösen? Vielleicht die Leerzeichen nicht löschen?
Grüße
Robert

305 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige