Format mitkopieren

Hi Forum,
vielleicht kann Mustafa (war mir schon einmal eine große Hilfe) oder sonst jemand mir bei einer Format-Kopier-Frage helfen! Komm einfach nicht darauf, wie man den Code für das Kopieren der Formate(Farbe der Zellen, Kommentare) bei dem nachfolgenden Skript so umschreibt, dass es funktioniert.
Hab zwar schon eine Lösung gefunden, die aber den Programmablauf um einiges verlangsamt.
nachfolgend steht das komplette Skript oder eine Beispieldatei:
https://www.herber.de/bbs/user/38442.xls
Hier die Codezeile um die es mir geht:
Dieser Vorgang soll z. B. (Farbe der Zellen,Kommentare) mit auf die einzelnen Blätter von der Haupttabelle mitkopiert!!!
Sheets(a).Cells(x, J) = Ws1.Cells(I, J)
mit dieser Skriptzeile funktionierts, aber sehr langsam.
'Ws1.Cells(I, J).Copy Sheets(a).Cells(x, J)
Komplettes Skript:
Option Explicit


Sub VonGesamtNachEinzelnKopieren()
Application.ScreenUpdating = False
'Initialisieren der Variablen
Dim I&, J&, LZ1&, LS1&, LZ2&, LS2&, a&, x&, y&, z&
Dim MainDat As String
Dim Ws1 As Worksheet
MainDat = "gesamt"
Set Ws1 = Sheets(MainDat)
LZ1 = GetLastRow(Ws1)
LS1 = GetLastCol(Ws1)
I = 6
x = 7
y = 7
z = 65536
Do While I < LZ1
I = I + 1
For J = 1 To LS1
For a = 2 To Sheets.Count
If InStr(1, UCase(Ws1.Cells(I, 1)), LCase(Sheets(a).Name), 1) Then
If Sheets(a).Cells(z, 1).End(xlUp).Offset(1, 0).Row < y Then x = y
Application.StatusBar = "Datenblatt: [ " & Sheets(a).Name & " ] wird bearbeitet II Kopiervorgang..."
'Es geht mir um diesen Teil hier:
Sheets(a).Cells(x, J) = Ws1.Cells(I, J)           '<<<<<<<<<<<<<<
'Ws1.Cells(I, J).Copy Sheets(a).Cells(x, J)        <<<<<<<<<<<<<< (2.Lösung)
End If
Next a
Next
x = x + 1
Loop
Set Ws1 = Nothing
Sheets(MainDat).Select
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub


Function GetLastCol(Ws As Worksheet) As Long
GetLastCol = Ws.Cells(1, Columns.Count).End(xlToLeft).Column
End Function


Function GetLastRow(Ws As Worksheet) As Long
GetLastRow = Ws.Range("A65536").End(xlUp).Row
End Function

___
Vielleicht ist es verständlicher, wenn man sich die Mappe anschaut.
Bin für jeden Vorschlag dankbar.
Gruß doey

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub VonGesamtNachEinzelnKopieren2() 'Initialisieren der Variablen Dim I&, ii&, jj As Integer, zz As Long, LS1&, a As Integer, y& Dim Ws1 As Worksheet Dim strName As String Application.ScreenUpdating = False Set Ws1 = Sheets("gesamt") ' Haupttabelle I = 7 ' Variable für Anfangszeile, hier wird ab Zeile 7 gesucht. y = 7 ' Variable zur Abfrage der Einfügezeile ' zu kopierenden Bereich bestimmen (Zeilen mit gleichem Namen) While I < Ws1.Cells(Rows.Count, 1).End(xlUp).Row ii = I strName = UCase(Ws1.Cells(ii, 1)) While strName = UCase(Ws1.Cells(ii + 1, 1)) ii = ii + 1 ' Zeile jj = Ws1.Cells(ii, Columns.Count).End(xlToLeft).Column ' akt. Spalte If LS1 < jj Then LS1 = jj ' max. Spalte Wend ' Zielblatt bestimmen (alle Datenblätter von 2-Rest durchlaufen) For a = 2 To Sheets.Count 'Name Einzelblatt mit Namen in Haupttabelle vergleichen If InStr(1, UCase(Ws1.Cells(ii, 1)), UCase(Sheets(a).Name), 1) > 0 Then Application.StatusBar = "Datenblatt: [ " & Sheets(a).Name & _ " ] wird bearbeitet II Kopiervorgang..." ' Einfügezeile bestimmen (hier mindestens Zeile y=7) zz = Sheets(a).Cells(Rows.Count, 1).End(xlUp).Row + 1 If zz < y Then zz = y ' Zeilenblock kopieren - mit allem Range(Ws1.Cells(I, 1), Ws1.Cells(ii, LS1)).Copy Sheets(a).Cells(zz, 1) Exit For ' Schleife über Blätter verlassen End If Next a I = ii + 1 ' Startzeile für nächsten Namenblock Wend Ws1.Select Set Ws1 = Nothing Application.StatusBar = False Application.ScreenUpdating = True End Sub

Option Explicit Sub ZeilenAufBlaetterverteilen() Dim Ws1 As Worksheet, zQA As Long, zQE As Long, strName As String, intB As Integer, zz As Long Const zZA As Long = 7 ' 1. Einfügezeile zQA = 7 ' 1. Quellzeile Set Ws1 = Sheets("gesamt") ' Quelltabelle Application.ScreenUpdating = False While zQA <= Ws1.Cells(Rows.Count, 1).End(xlUp).Row zQE = zQA ' zu kopierenden Bereich bestimmen (mit gleichem Namen) strName = UCase(Ws1.Cells(zQE, 1)) While strName = UCase(Ws1.Cells(zQE + 1, 1)): zQE = zQE + 1: Wend For intB = 2 To Sheets.Count If strName = UCase(Sheets(intB).Name) Then ' Blattname = Name? zz = Sheets(intB).Cells(Rows.Count, 1).End(xlUp).Row + 1 ' Einfügezeile bestimmen If zz < zZA Then zz = zZA Range(Ws1.Rows(zQA), Ws1.Rows(zQE)).Copy Sheets(intB).Cells(zz, 1) ' kopieren Exit For End If Next intB zQA = zQE + 1 ' Startzeile für nächsten Namenblock Wend Application.ScreenUpdating = True End Sub

Hi Erich,
habe die kürzere Version genommen. Das macht nichts aus, wenn "ganze Zeilen" kopiert werden.
Das mit der Abfrage, ob die Zeilen in den einzelnen Tabellen ausreichend sind, spielt hier keine Rolle. So viele Datensätze pro Person sind es nicht, dass man Platzprobleme bekommen könnte.
Der Block für die Namen bleibt eigentlich immer gleich. Es kann sein, dass ein paar Datensätze zu der jeweiligen Person hinzukommen, aber das war's schon.
Genauso ist es bei den Spalten! So viele sind es hier auch nicht.
Müsstest mir noch einmal unter die Arme greifen!
Wollte deinen Vorschlag aufgreifen und das Skript mit:
falls Tabelle nicht vorhanden, die MSGBOX-Fehlermeldung oder ein neues Blatt mit fehlenden Blättern anlegen
einbauen!
Will bei mir einfach nicht funktionieren:
Man muss bei dieser Skriptzeile...
If strName = UCase(Sheets(intB).Name) Then ' Blattname = Name?
...doch nur eine Abzweigung mit "Else" schaffen, oder? Hab keine Ahnung, komm nicht drauf.
Du weißt das bestimmt aus dem FF.
Vielen Dank nochmal für deine Bemühungen.
Gruß doey

Option Explicit Sub ZeilenAufBlaetterVerteilen2() Dim wsQ As Worksheet, wsZ As Worksheet, wsB As Worksheet Dim zQA As Long, zQE As Long, strName As String, intMsg As Integer, zz As Long Const zZA As Long = 7 ' 1. Einfügezeile zQA = 7 ' 1. Quellzeile Set wsQ = Sheets("gesamt") ' Quelltabelle Application.ScreenUpdating = False Do While zQA <= wsQ.Cells(Rows.Count, 1).End(xlUp).Row strName = UCase(wsQ.Cells(zQA, 1)) ' bearbeiteter Name If strName = UCase(wsQ.Name) Then _ MsgBox "'" & wsQ.Name & "' darf nicht vorkommen!", vbCritical, "Abbruch": Exit Sub For Each wsB In Worksheets ' Blattname = Name suchen If strName = UCase(wsB.Name) Then Set wsZ = wsB: Exit For Next wsB If wsZ Is Nothing Then ' Blattname nicht gefunden intMsg = MsgBox("Soll Blatt '" & wsQ.Cells(zQA, 1) & "' neu angelegt werden?", _ vbYesNoCancel) Select Case intMsg Case vbYes Set wsZ = Worksheets.Add(after:=Worksheets(1)) ' neues Blatt anlegen wsZ.Name = wsQ.Cells(zQA, 1) ' und benennen zz = zZA ' 1. Einfügezeile Case vbCancel Exit Do ' Do-Schleife verlassen - Ende End Select Else zz = wsZ.Cells(Rows.Count, 1).End(xlUp).Row + 1 ' Einfügezeile bestimmen If zz < zZA Then zz = zZA intMsg = vbYes End If zQE = zQA ' Ende des zu kopierenden Bereichs While strName = UCase(wsQ.Cells(zQE + 1, 1)): zQE = zQE + 1: Wend If intMsg = vbYes Then _ Range(wsQ.Rows(zQA), wsQ.Rows(zQE)).Copy wsZ.Cells(zz, 1) ' kopieren Set wsZ = Nothing ' Zielblatt wieder "vergessen" zQA = zQE + 1 ' Startzeile des nächsten Bereichs Loop Application.ScreenUpdating = True End Sub

' zu kopierenden Bereich bestimmen (Zeilen mit gleichem Namen) While I < Ws1.Cells(Rows.Count, 1).End(xlUp).Row ii = I strName = UCase(Ws1.Cells(ii, 1)) LS1 = Ws1.Cells(ii, Columns.Count).End(xlToLeft).Column ' akt. Spalte While strName = UCase(Ws1.Cells(ii + 1, 1)) ii = ii + 1 ' Zeile jj = Ws1.Cells(ii, Columns.Count).End(xlToLeft).Column ' akt. Spalte If LS1 < jj Then LS1 = jj ' max. Spalte Wend

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread