Registriert seit: 05.10.2014
Version(en): 2013 Pro plus
14.07.2015, 18:27
(Dieser Beitrag wurde zuletzt bearbeitet: 14.07.2015, 18:48 von knallebumm.)
Hallo,
ich ziehe mir die Daten für eine Tabelle aus mehreren Tabellen mit folgenden Code. Klappt wunderbar.
Ist es möglich das auch die Formatierung der einzelnen Zellen mit übernommen wird?
Also wenn ich z. B. in Tabelle 1 eine Zelle gelb markiert habe, dass diese dann auch gelb in der Zieltabelle erscheint?
Ich hab mir schon aus diversen Foren Schnipsel rauskopiert und ausprobiert, aber das lief alles nicht so wirklich.
Vielleicht könnt Ihr mir helfen.
Gruß
Thomas
Code: Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim i As Long
Dim varQ As Variant
If Sh.Name = "Einteilung alle Ligen" Then
Sh.Range(Sh.Cells(5, 1), Sh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 10)) = ""
For i = 1 To 4
With Worksheets(i)
If Len(.Cells(3, 1)) Then
varQ = .Range(.Cells(3, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 9).Value
Else
ReDim varQ(0)
End If
End With
If UBound(varQ) Then
With Sh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(varQ))
.Value = Worksheets(i).Name
.Offset(, 1).Resize(, UBound(varQ, 2)).Value = varQ
End With
End If
Next i
End If
End Sub
Beste Grüße
Thomas
Registriert seit: 11.04.2014
Version(en): Office 2007
Hallo Thomas,
Du schreibst einen Tabellenbereich in ein Array und danach kopierst Du das Array wieder in eine Tabelle. Damit kannst Du keine Formate kopieren. Versuchs mal so (ist aber ungetestet) Und mache dies an einer Kopie deiner Datei.
Code: Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim i As Long, lngC As Long
Dim varQ As Variant
If Sh.Name = "Einteilung alle Ligen" Then
Sh.Range(Sh.Cells(5, 1), Sh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 10)) = ""
For i = 1 To 4
With Worksheets(i)
If Len(.Cells(3, 1)) Then
lngC = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row + 1
Sh.Cells(lngC, 1).Value = Worksheets(i).Name
.Range(.Cells(3, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 9).Copy Sh.Cells(lngC + 1, 2)
Else
ReDim varQ(0)
End If
End With
' If UBound(varQ) Then
' With Sh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(varQ))
' .Value = Worksheets(i).Name
' .Offset(, 1).Resize(, UBound(varQ, 2)).Value = varQ
' End With
' End If
Next i
End If
End Sub
Gruß Stefan
Win 10 / Office 2016
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
Hallo Thomas,
da Du nicht mit der Kopierfunktion arbeitest, müsstest Du die Formate der einzelnen Zellen auslesen und übertragen. Du kannst dafür keine Zellbereiche, wie in Deinem Makro, verwenden:
varQ = .Range(.Cells(3, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 9).Value
Stattdessen müsstest Du ein oder zwei Schleifen über die Zeilen und Spalten des Bereichs nehmen.
Wie man eine Zelle formatiert, könntest Du aufzeichnen. Das könnte so aussehen:
Code: Sub Makro1()
'
' Makro1 Makro
'
'
Range("A4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
Wenn Du z.B. nur die Farbe übernehmen willst, brauchst Du nicht alles, da reicht
Du machst das jetzt etwas anders und übergibst die Farbe an die neue Zelle, im Prinzip:
Code: ...
rngNeueZelle.Interior.Color = rngAlteZelle.Interior.Color
...
aber wie oben gesagt, in der oder den Schleifen ...
. \\\|/// Hoffe, geholfen zu haben.
( ô ô ) Grüße, André aus G in T
ooO-(_)-Ooo (Excel 97-2019+365)
Registriert seit: 05.10.2014
Version(en): 2013 Pro plus
Danke erst mal für die Antworten und Lösungsvorschläge.
@ Stefan
Dein Code macht vom Grund her erst mal das was ich wollte.
Aber von den TabellenBlättern werden bei den ersten 3 nur die erste Zeile übernommen und beim 4 Blatt übernimmt er alles bis auf den Blattnamen der in Spalte A in jeder Zeile erscheinen soll.
Die Zeilen und Spalten sehen für mich in beiden Codes ziemlich gleich aus, von daher stehe ich etwas auf dem Schlauch.
@ André
Langsam habe ich mich schon ein bisschen eingefuchst in VBA, ich kann auch schon das eine oder andere ändern und anpassen, aber ich wüsste jetzt nicht wie ich deinen zweiten Teil verwerten soll.
Beste Grüße
Thomas
Registriert seit: 11.04.2014
Version(en): Office 2007
Hallo Thomas,
könntest Du die Datei hier hochladen?
Gruß Stefan
Win 10 / Office 2016
Registriert seit: 05.10.2014
Version(en): 2013 Pro plus
Hallo Stefan,
ja das kann ich machen.
Musste sie aber erst kastrieren.
Einteilungsvorlage berechnet1.xlsm (Größe: 121,01 KB / Downloads: 2)
Beste Grüße
Thomas
Registriert seit: 11.04.2014
Version(en): Office 2007
Hallo Thomas,
meinst Du so?
Code: Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim i As Long, lngC As Long, lngA As Long
If Sh.Name = "Einteilung alle Ligen" Then
'statt sh.cells(rows.count,1) heißt es jetzt sh.cells(rows.count,2)
Sh.Range(Sh.Cells(5, 1), Sh.Cells(Sh.Rows.Count, 2).End(xlUp).Offset(1).Resize(, 10)) = ""
For i = 1 To 4
With Worksheets(i)
If Len(.Cells(3, 1)) Then
'hier gilt das gleiche wie oben
lngC = Sh.Cells(Sh.Rows.Count, 2).End(xlUp).Row + 1
lngA = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
Sh.Cells(lngC, 1).Resize(lngA).Value = Worksheets(i).Name
.Range(.Cells(3, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 9).Copy Sh.Cells(lngC + 1, 2)
End If
End With
Next i
End If
End Sub
Gruß Stefan
Win 10 / Office 2016
Folgende(r) 1 Nutzer sagt Danke an Steffl für diesen Beitrag:1 Nutzer sagt Danke an Steffl für diesen Beitrag 28
• knallebumm
Registriert seit: 05.10.2014
Version(en): 2013 Pro plus
Hallo Stefan,
ja genau so.
Danke.
Man kann sich ja viel anlesen und das ganze Internet durchsuchen,
irgendwas findet man immer, nur das zusammenfügen der Puzzelteile ist das Problem.
Bei den Formeln ist das meiner Meinung nach etwas leichter.
Vielleicht weil es "greifbarer" ist.
Beste Grüße
Thomas
|