Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Format mit Kopieren
#1
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
Antworten Top
#2
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
Antworten Top
#3
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)
Antworten Top
#4
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
Antworten Top
#5
Hallo Thomas,

könntest Du die Datei hier hochladen?
Gruß Stefan
Win 10 / Office 2016
Antworten Top
#6
Hallo Stefan,
ja das kann ich machen.
Musste sie aber erst kastrieren.





.xlsm   Einteilungsvorlage berechnet1.xlsm (Größe: 121,01 KB / Downloads: 2)
Beste Grüße
Thomas
Antworten Top
#7
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:
  • knallebumm
Antworten Top
#8
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
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste