Zellen mit Formatierung in mehrere Tabellenblätter
08.02.2017 17:14:05
Ralf
bei einen Makro rauche ich Hilfe, kenne mich bisher damit nicht so gut aus.
Folgendes Problem:
Es gibt 2 Tabellenblätter, "Erfassung" und "Auswertung".
Im TB "Erfassung" stehen in mehreren Zeilen verschiedene Daten, die an bestimmte Stellen im zweiten TB "Auswertung" kopiert werden.
Im ersten Teil das Makros werden die Daten direkt von einem zum anderen TB übernommen. Dann werden neue Tabellenblätter mit einem neuen Namen (aus den Zellen der Spalte "D" des TB "Erfassung") erstellt.
Danach werden wiederum aus den TB "Erfassung" Daten übernommen, diesmal in die neu erstellten Tabellenblätter. Dabei werden nur Daten übernommen, wenn in den Quellzellen der Wert größer als 1 ist. Dementsprechen werden auch die Überschriften "dynamisch" übernommen.
Das klappt auch alles sehr gut, die Werte werden übernommen, so wie es sein soll. Nun sollen aber neben den Werten auch die (benutzerdefinierten) Formate der Quellzellen übernommen werden.
Der Teil des Codes dafür ist:
'Nun neuer Durchlauf, um die Spalten AE bis AK jeweils in die betreffenden Tabellenblätter zu _
kopieren.
For lngCount = 4 To lngRow 'Was bwirkt dieser Eintrag?
strTab = .Cells(lngCount, 4).Text 'Name des Arbeitsblatt, in das die Daten geschrieben werden _
sollen = SPALTENNUMMER (4=D) in Erfassung
lngEinf = 10 'Zeilen, ab der die Daten eingefügt werden sollen = 10
For lngSpalte = 31 To 37 'Spalten AE=31 bis AK=37
If .Cells(lngCount, lngSpalte).Value > 1 Then
Worksheets(strTab).Cells(lngEinf, 6) = .Cells(1, lngSpalte).Value 'Überschrift von Zeile 1 in _
Spalte F = 6 kopieren
Worksheets(strTab).Cells(lngEinf, 8) = .Cells(lngCount, lngSpalte).Value 'Wert ab Zeile _
lngCount in Spalte H = 8 kopieren
lngEinf = lngEinf + 1 'Zähler für Einfügezeile erhöhen
End If
Next lngSpalte
Next lngCount
'Nun neuer Durchlauf, um die Spalten AE bis AK jeweils in die betreffenden Tabellenblätter zu _
kopieren.
For lngCount = 4 To lngRow 'Was bwirkt dieser Eintrag?
strTab = .Cells(lngCount, 4).Text
lngEinf = 32
For lngSpalte = 40 To 53
If .Cells(lngCount, lngSpalte).Value > 1 Then
Worksheets(strTab).Cells(lngEinf, 2) = .Cells(1, lngSpalte).Value
Worksheets(strTab).Cells(lngEinf, 6) = .Cells(2, lngSpalte).Value
Worksheets(strTab).Cells(lngEinf, 8) = .Cells(lngCount, lngSpalte).Value
lngEinf = lngEinf + 1
End If
Next lngSpalte
Next lngCount
Worksheets(3).Select
End With
Was muss da noch eingefügt oder geändert werde, um die Werte und Formate zu kopieren?
Vielen Dank für die Hilfe hier.