AW: Kommentare mit Format übertragen
06.07.2020 12:35:15
fcs
Hallo Lemmy,
dazu muss in den entsprechenden Zeilen die 2 durch eine 3 und die 1 durch eine 2 ersetzt werden.
Zur Vereinfachung hab ich 2 Variablen eingefügt mit diesen Werten. Dann wird auch offensichtlicht, wo do die Änderungen nötig sind.
LG
Franz
'Makro in einem allgemeinen Modul gespeichert.
Sub Kommentare_extrahieren()
Dim wksListe As Worksheet
Dim wksKommentar As Worksheet
Dim zeiL As Long, zeiK As Long, zeiL_1 As Long, zeiK_1 As Long
Dim varText As Variant, bolKommentar As Boolean, strKommentar As String
Dim rngZelle As Range
Dim objTextframe As TextFrame
Dim iPos As Integer, iPos1 As Integer, iPos2 As Integer
Dim arrColor(), lngColor As Long, iColor As Integer
Dim StatusCalc As Long
Dim spaWert As Long, spaKom As Long
If MsgBox("Kommentar-Auswertung aktualisieren?", _
vbQuestion + vbOKCancel, "Kommetare auswerten") = vbCancel Then Exit Sub
'Makrobremsen lösen
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
Set wksListe = ActiveWorkbook.Worksheets("Tabelle1")
zeiL_1 = 7 'Zeile mit 1. Wert in Auflistung
Set wksKommentar = ActiveWorkbook.Worksheets("Kommentar ")
zeiK_1 = 7 'Zeile mit 1. Wert in Kommentare
spaWert = 2 'Spalte B - Spalte für Text aus Tabelle 1
spaKom = 3 'Spalte C - Spalte für Kommentar-Text aus Tabelle 1
With wksKommentar
'vorhandene Einträge löschen
zeiK = .Cells(.Rows.Count, spaWert).End(xlUp).Row
If zeiK >= zeiK_1 Then
.Range(.Rows(zeiK_1), .Rows(zeiK)).Clear
End If
zeiK = zeiK_1 'Startzeile im Zielblatt detzen
End With
With wksListe
varText = ""
'Zeilen in Liste abarbeiten
For zeiL = zeiL_1 To .Cells(.Rows.Count, 1).End(xlUp).Row + 1
Set rngZelle = .Cells(zeiL, 1)
'Prüfen, ob sich der Text in der Zeile geändert hat
If rngZelle.Value varText Then
If zeiL > zeiL_1 Then
'Wort in Zelle in Spalte Aeintragen
wksKommentar.Cells(zeiK, spaWert).Value = varText
If bolKommentar = False Then
wksKommentar.Cells(zeiK, spaKom).Value = "kein Kommentar"
Else
'Kommentar-Text in Spalte B eintragen
wksKommentar.Cells(zeiK, spaKom).Value = strKommentar
'Text in Zelle entsprechend gespeicherten Werten farbig formatieren
If iColor > 0 Then
With wksKommentar.Cells(zeiK, spaKom)
For iColor = 1 To UBound(arrColor, 2)
.Characters(arrColor(1, iColor), _
arrColor(2, iColor)).Font.Color = arrColor(3, iColor)
Next
End With
End If
End If
zeiK = zeiK + 1
End If
'Variablen für nächsten Eintrag setzen
varText = rngZelle.Value
bolKommentar = False
iColor = 0
Erase arrColor
End If
If rngZelle.Comment Is Nothing Then
'kein Kommentar in Zelle vorhanden
Else
bolKommentar = True
With rngZelle.Comment
strKommentar = .Text
iPos1 = 1
Set objTextframe = .Shape.TextFrame
'Farbe des 1. Buchstabens merken
lngColor = objTextframe.Characters(iPos1, 1).Font.Color
For iPos = 2 To Len(strKommentar)
'prüfen, ob sich die FRarbe des Buchstabens geändert hat
If objTextframe.Characters(iPos, 1).Font.Color lngColor Then
'1. und letzte Position mit der Farbe in Array schreiben
iPos2 = iPos - 1
iColor = iColor + 1
ReDim Preserve arrColor(1 To 3, 1 To iColor)
arrColor(1, iColor) = iPos1
arrColor(2, iColor) = iPos2
arrColor(3, iColor) = lngColor
'neue 1. Position und Farbe merken
iPos1 = iPos
lngColor = objTextframe.Characters(iPos, 1).Font.Color
End If
Next
'Werte für letztes Zeichen in Array schreiben
iPos2 = Len(strKommentar)
iColor = iColor + 1
ReDim Preserve arrColor(1 To 3, 1 To iColor)
arrColor(1, iColor) = iPos1
arrColor(2, iColor) = iPos2
arrColor(3, iColor) = lngColor
End With
End If
Next
End With
'Inhalte der Zellen vertikal zentrieren
With wksKommentar
.Range(.Cells(zeiK_1, spaWert), .Cells(zeiK, spaKom)).VerticalAlignment = xlCenter
.Activate
End With
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
.Calculate
End With
End Sub