Option Explicit
Private strBlattname As String
Private strKommentar As String
Public Sub InhaltAuslesen(ByVal intRow As Integer)
strBlattname = "Sheet1"
With Worksheets(strBlattname)
strKommentar = _
.Cells(1, 2).Value & String$(10, " ") & .Cells(1, 3).Value & Chr(10) _
& .Cells(intRow, 2).Value & String$(12, " ") & .Cells(intRow, 3).Value & Chr(10) & Chr(10) _
& .Cells(1, 9).Value _
& String$(20, " ") _
& .Cells(1, 4).Value & Chr(10) _
& .Cells(intRow, 9).Value & .Cells(intRow, 10).Value _
& String$(16, " ") _
& .Cells(intRow, 4).Value & Chr(10) & Chr(10) _
& .Cells(1, 6).Value & Chr(10) & .Cells(intRow, 6).Value & Chr(10) & Chr(10) _
& .Cells(1, 5).Value & Chr(10) & .Cells(intRow, 5).Value & Chr(10) & Chr(10) _
& .Cells(1, 8).Value & Chr(10) & .Cells(intRow, 8).Value & Chr(10) _
& .Cells(1, 7).Value & Chr(10) & .Cells(intRow, 7).Value
End With
Call CreateComment(intRow)
End Sub
Public Sub CreateComment(ByVal intRow As Integer)
Dim objComment As Comment
Dim lngIndex As Long, lngMax As Long
Dim lngArrStart(1 To 2) As Long, _
lngArrLength(1 To 2) As Long
With Worksheets("Sheet2").Cells(2, 2)
If Not .Comment Is Nothing Then Exit Sub
Set objComment = .AddComment(strKommentar)
End With
With objComment.Shape.TextFrame
With .Characters.Font
.Bold = True
.Underline = xlUnderlineStyleSingle
End With
If intRow > 1 Then _
lngMax = 7 _
Else: lngMax = 4
For lngIndex = 1 To lngMax
With Worksheets(strBlattname)
Select Case lngIndex
Case Is = 1
lngArrStart(1) = Len(.Cells(1, 2).Text) + 1: lngArrLength(1) = 10
If intRow > 1 Then
lngArrStart(2) = Len(.Cells(1, 2).Text) + 10 + _
Len(.Cells(1, 3).Text) + 2
lngArrLength(2) = Len(.Cells(intRow, 2).Text)
End If
Case Is = 2
lngArrStart(1) = lngArrStart(1) + lngArrLength(1) + Len(.Cells(1, 3).Text) _
+ Len(.Cells(intRow, 2).Text) + 1
lngArrLength(1) = 12
If intRow > 1 Then
lngArrStart(2) = lngArrStart(2) + lngArrLength(2) + 12
lngArrLength(2) = Len(.Cells(intRow, 3).Text)
End If
Case Is = 3
lngArrStart(1) = lngArrStart(1) + lngArrLength(1) + Len(.Cells(intRow, 3).Text) + _
2 + Len(.Cells(1, 9).Text)
lngArrLength(1) = 20
If intRow > 1 Then
lngArrStart(2) = lngArrStart(2) + lngArrLength(2) + 2 + Len(.Cells(1, 9).Text) + _
20 + Len(.Cells(1, 4).Text)
lngArrLength(2) = Len(.Cells(intRow, 9).Text) + Len(.Cells(intRow, 10).Text) + _
16 + Len(.Cells(intRow, 4).Text) + 2
End If
Case Is = 4
lngArrStart(1) = lngArrStart(1) + lngArrLength(1) + Len(.Cells(1, 4).Text) + _
1 + Len(.Cells(intRow, 9).Text) + Len(.Cells(1, 10).Text)
lngArrLength(1) = 16
If intRow > 1 Then
lngArrStart(2) = lngArrStart(2) + lngArrLength(2) + 1 + Len(.Cells(1, 6).Text) + 1
lngArrLength(2) = Len(.Cells(intRow, 6).Text)
End If
Case Is = 5
lngArrStart(2) = lngArrStart(2) + lngArrLength(2) + 2 + Len(.Cells(1, 5).Text) + 1
lngArrLength(2) = Len(.Cells(intRow, 5).Text)
Case Is = 6
lngArrStart(2) = lngArrStart(2) + lngArrLength(2) + 2 + Len(.Cells(1, 8).Text) + 1
lngArrLength(2) = Len(.Cells(intRow, 8).Text)
Case Is = 7
lngArrStart(2) = lngArrStart(2) + lngArrLength(2) + 1 + Len(.Cells(1, 7).Text) + 1
lngArrLength(2) = Len(.Cells(intRow, 7).Text)
End Select
End With
If lngIndex <= 4 Then _
.Characters(Start:=lngArrStart(1), Length:=lngArrLength(1)).Font.Underline = xlUnderlineStyleNone
If intRow > 1 Then
With .Characters(Start:=lngArrStart(2), Length:=lngArrLength(2)).Font
.Bold = False
.Underline = xlUnderlineStyleNone
End With
End If
Next
End With
Set objComment = Nothing
End Sub