Alle Tabellen in ein Registerblatt

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Werner,
ich wollte es erstmal simpel halten. Sry für die zu kurze Beschreibung.
Was habe ich vor?:
Ich habe eine Tabelle mit mehreren Registerkarten. Dort sind Bewertungen hinterlegt (leider spuckt das Free Tool keine Gesamttabelle aus). Person E mochte bspw. das Thema A (von Personen A, B, C und D) und hat 100/100Punkten vergeben. Zum Schluss sollen diese Werte in einer Bewertungsmatrix stehen (Anzahl der Spalten und Zeilen noch ungewiss).
Was möchte ich in Excel realisieren?:
1. Dabei möchte ich zunächst alle Tabellen dieser Registerkarten in eine kopieren (untereinander). In der anonymisierten Tabelle funktioniert das Skript von Basti, aber in der richtigen Zusammenfassungs-Tabelle lässt das Skript einige Zellen, wo eig. die Zuordnungen der Fragen drinstehen sollten heraus. Ebenso sind einige doppelt abgefragt und ich weiss nicht warum.
2. Danach möchte ich irgendwie eine Matrix erstellen
hier ist die Datei: https://www.herber.de/bbs/user/147599.xlsm
Ich bedanke mich schonmal vorab für deine Hilfe.

Hallo Gerd,
die Datei habe ich weiter oben hochgeladen. Hier ist die Datei nochmal: https://www.herber.de/bbs/user/147599.xlsm
Mittlerweile habe ich eine Lösung gefunden. Die doppelten Werte stammen vom letzten Reiter, d.h. der Auslesereiter hat sich selber ausgelesen. Nun muss ich nur noch herausfinden, warum sich das Skript verschluckt und einige Zellen auslässt
Hier die Teillösung, siehe Kommentar


Sub TabellenKopierenUntereinander()
Dim i As Integer
Dim z As Integer
Dim r As Long, c As Long
Dim SZ As Worksheet
Dim rng()
Set SZ = Sheets("Zusammenfuegen")
With SZ
z = .Cells(.Rows.Count, 1).End(xlUp).Row
If z = 1 Then z = 2
.Range(.Cells(2, 1), .Cells(z, 3)).ClearContents
End With
z = 2
With ActiveWorkbook
For i = 1 To .Worksheets.Count - 1 '-1, da das letzte Worksheet "Zusammenfügen nicht mitgezählt werden soll"
rng = .Worksheets(i).UsedRange.Value
For r = LBound(rng, 1) + 1 To UBound(rng, 1)
For c = LBound(rng, 2) To UBound(rng, 2)
With SZ
.Cells(z, c) = rng(r, c)
End With
Next
z = z + 1
Next
Next
End With
End Sub

Public Sub TabellenKopierenUntereinander() Dim ws As Worksheet, loLetzte As Long Application.ScreenUpdating = False With Worksheets("Zusammenfuegen") loLetzte = .Cells(.Rows.Count, "A").End(xlUp).Row If loLetzte > 1 Then .Range("A2:E" & loLetzte).ClearContents End If End With For Each ws In ThisWorkbook.Worksheets If ws.Name Like "RATING*" Then With ws loLetzte = .Cells(.Rows.Count, "A").End(xlUp).Row If loLetzte > 1 Then .Range("A2:E" & loLetzte).Copy With Worksheets("Zusammenfuegen") .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "A").Offset(1).PasteSpecial _ Paste:=xlPasteValuesAndNumberFormats End With End If End With End If Next ws End Sub

Sub TabellenKopierenUntereinander() Dim i As Integer Dim z As Integer Dim r As Long, c As Long Dim SZ As Worksheet Dim rng() Set SZ = Sheets("Zusammenfuegen") With SZ z = .Cells(.Rows.Count, 1).End(xlUp).Row If z = 1 Then z = 2 .Range(.Cells(2, 1), .Cells(z, 3)).ClearContents End With z = 2 With ActiveWorkbook For i = 1 To .Worksheets.Count - 2 'Minus die Anzahl der Letzten Reiter, da die letzten Worksheet "Zusammenfügen" und "Matrix" nicht nochmal aufgelistet werden sollen" rng = .Worksheets(i).UsedRange.Value For r = LBound(rng, 1) + 1 To UBound(rng, 1) For c = LBound(rng, 2) To UBound(rng, 2) With SZ .Cells(z, c) = rng(r, c) End With Next z = z + 1 Next Next End With End Sub

Beliebteste Forumthreads (12 Monate)

Alle Tabellen in ein Registerblatt

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread