• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Comments vanuit een cel kopieeren

  • Onderwerp starter Onderwerp starter AatB
  • Startdatum Startdatum
Status
Niet open voor verdere reacties.
AatB

AatB

Gebruiker
Lid geworden
15 dec 2007
Berichten
257
Hallo,

Ik heb met hulp van het forum onderstaande macro gemaakt;
Deze voegt van de geselecteerde cellen de text die in een cel staat toe aan het COMMENT van de cel.

Als je de macro nu twee keer komt de text in de cel ook twee keer in het comment.
Ik wil dit voorkomen door in de cel een * voor de tekst te zetten en hierop verder te controleren.

Kunnen jullie me even helpen hoe ik dit moet doen?

O ja, ok nog een klein schoonheidsfoutje. Als ik maar 1 cel selecteer en er staat niets in, komt er een foutmelding op regel 4 (Fout 424 - Obeject vereist). Misschien dat jullie hier ook een oplossing voor weten.

mvg,

Aat


Code: 
Sub TextIntoComments()
    Dim cell As Range
    Dim ccc As String
    
    For Each cell In Intersect(Selection, ActiveSheet.UsedRange)
    
    If Trim(cell.Text) <> "" Then
        ccc = Format(Date, "ddmm") & ": " & cell.Text
    End If
            
    If cell.Comment Is Nothing Then
        cell.AddComment.Text ccc
    Else
        cell.Comment.Text (ccc & Chr(10) & cell.Comment.Text)
    End If
    
    cell.Comment.Visible = False
    cell.Comment.Shape.TextFrame.AutoSize = True
    
    Next cell
End Sub
 
Laatst bewerkt:
Verander dan deze regel:

Code: 
cell.Comment.Text (ccc & Chr(10) & cell.Comment.Text)

bvb. in:

Code: 
cell.Comment.Text ccc

Wigi
 
AatB, Als het alleen gaat om het toevoegen van het comment als er 'nog géén comment' in die cel bestaat, zou ik het if-blokje een stukje inkorten (dus zonder het 'Else' gedeelte)
Code: 
If cell.Comment Is Nothing [COLOR="Blue"]And Not IsEmpty(cell)[/COLOR] Then
    cell.AddComment.Text ccc
End If
En het blauwe deeltje rekent af met het 'schoonheidsfoutje'....

Groet, Leo
 
Laatst bewerkt:
Leo

Een cel kan ondertussen gewijzigd zijn, en dan zal jouw code de opmerkingen niet meer updaten (als je de Else tak wegneemt).
 
Wigi zei:
Verander dan deze regel:

Code: 
cell.Comment.Text (ccc & Chr(10) & cell.Comment.Text)

bvb. in:

Code: 
cell.Comment.Text ccc

Wigi
Klik om te vergroten...

Voorbeeld:
Tekst in CEL is "Test commentaar"
Na het uitvoeren van de macro is de tekst in het COMMENT van de CEL
"2912: Test commentaar"

Na twee keer de macro uitvoeren is de tekst in het COMMENT van de CEL
"2912: Test commentaar"
"2912: Test commentaar"

Dit wil ik voorkomen. Aangezien ik de tekst in de CEL wil behouden, moet ik een controle inbouwen of deze tekst al in het COMMENT voorkomt.

Ik dacht er hierbij aan om een * voor de tekst in de CEL te plaatsen, maar ik weet niet hoe ik dit moet doen. Of je zou ook de tekst in de CEL kunnen vergelijken met de eerste regel van het COMMENT of zoiets.

Aat
 
@Wigi, Yep dat besefte ik me óók. Maar ik gokte er op dat deze code slechts 1x per sheet gedraaid zou worden...

@AatB, Het vergelijken zal lastig worden omdat je een timestamp (datum) aan je comment toevoegd.

Groet, Leo

P.s. Ik had in m'n eerdere post nog een aanpassing gemaakt vwbt het 'schoonheidsfoutje' maar de Topic loopt sneller dan ik 'm kan bijhouden...:D
 
Zoiets?

Code: 
Sub TextIntoComments()
    
    Dim cell As Range
    Dim ccc As String
    Dim sCommentText As String

    For Each cell In Intersect(Selection, ActiveSheet.UsedRange)
    
        With cell

            If Trim(.Text) <> "" Then
                ccc = Format(Date, "ddmm") & ": " & .Text
            End If
    
            If .Comment Is Nothing Then
            
                .AddComment.Text ccc
                
            Else
                
                sCommentText = .Comment.Text
                
                If InStr(sCommentText, ccc) > 0 Then
                
                    sCommentText = Replace(sCommentText, ccc, "", 1)
                    
                End If
                
                .Comment.Text ccc & Chr(10) & sCommentText
                .Comment.Text = Replace(.Comment.Text, Chr(10) & Chr(10), Chr(10))
                
            End If
    
            .Comment.Visible = False
            .Comment.Shape.TextFrame.AutoSize = True
            
        End With

    Next
End Sub

ongeteste code

Wigi
 
Ginger zei:
AatB, Als het alleen gaat om het toevoegen van het comment als er 'nog géén comment' in die cel bestaat, zou ik het if-blokje een stukje inkorten (dus zonder het 'Else' gedeelte)
Code: 
If cell.Comment Is Nothing [COLOR="Blue"]Or Not IsEmpty(cell)[/COLOR] Then
    cell.AddComment.Text ccc
End If
En het blauwe deeltje rekent af met het 'schoonheidsfoutje'....

Groet, Leo
Klik om te vergroten...

Helaas het schoonheidsfoutje blijft......
Als ik 1 lege cel selecteer dan krijg ik de foutmelding.
Als ik 2 lege cellen selecteer dan niet.

Aat
 
AatB, sorry... het moest niet Or maar And zijn....

Toevoeging op de prima wending van Wigi:
vervang:
Code: 
If .Comment Is Nothing Then
voor
Code: 
If .Comment Is Nothing And Not IsEmpty(cell) Then
verwijder het '= teken' uit de code:
Code: 
                .Comment.Text ccc & Chr(10) & sCommentText
                .Comment.Text [COLOR="Blue"]=[/COLOR] Replace(.Comment.Text, Chr(10) & Chr(10), Chr(10))
voor:
Code: 
                 .Comment.Text ccc & Chr(10) & sCommentText
                .Comment.Text Replace(.Comment.Text, Chr(10) & Chr(10), Chr(10))
(het 'comment' staat Wigi's syntax niet toe!)

Groet, Leo
 
Laatst bewerkt:
AatB zei:
Helaas het schoonheidsfoutje blijft......
Als ik 1 lege cel selecteer dan krijg ik de foutmelding.
Als ik 2 lege cellen selecteer dan niet.

Aat
Klik om te vergroten...

Tja, en dat is ook logisch. Je neemt de intersectie van 2 dingen, maar je test niet in het minst of er wel een intersectie is... dat kan niet goed gaan dan in bepaalde gevallen.
 
Wigi zei:
Zoiets?

Code: 
Sub TextIntoComments()
    
    Dim cell As Range
    Dim ccc As String
    Dim sCommentText As String

    For Each cell In Intersect(Selection, ActiveSheet.UsedRange)
    
        With cell

            If Trim(.Text) <> "" Then
                ccc = Format(Date, "ddmm") & ": " & .Text
            End If
    
            If .Comment Is Nothing Then
            
                .AddComment.Text ccc
                
            Else
                
                sCommentText = .Comment.Text
                
                If InStr(sCommentText, ccc) > 0 Then
                
                    sCommentText = Replace(sCommentText, ccc, "", 1)
                    
                End If
                
                .Comment.Text ccc & Chr(10) & sCommentText
                .Comment.Text = Replace(.Comment.Text, Chr(10) & Chr(10), Chr(10))
                
            End If
    
            .Comment.Visible = False
            .Comment.Shape.TextFrame.AutoSize = True
            
        End With

    Next
End Sub

ongeteste code

Wigi
Klik om te vergroten...


Na nog een paar aanpassingen werkt het nu.

Bedankt allemaal voor jullie tips.....:p

Code: 
Sub TextIntoComments1()
    
    Dim cell As Range
    Dim ccc As String
    Dim sCommentText As String

    For Each cell In Intersect(Selection, ActiveSheet.UsedRange)
    
        With cell
            ccc = ""
            If Trim(.Text) <> "" Then
                ccc = Format(Date, "ddmm") & ": " & .Text
            End If
    
            If ccc <> "" Then
            If .Comment Is Nothing Then
            
                .AddComment.Text ccc
                
            Else
                
                sCommentText = .Comment.Text
                
                If InStr(sCommentText, ccc) > 0 Then
                
                    sCommentText = Replace(sCommentText, ccc, "", 1)
                    
                End If
                
                .Comment.Text ccc & Chr(10) & sCommentText
                .Comment.Text Replace(.Comment.Text, Chr(10) & Chr(10), Chr(10))
                
            End If
    
            .Comment.Visible = False
            .Comment.Shape.TextFrame.AutoSize = True
            End If
            
        End With

    Next
End Sub
 
Laatst bewerkt:
Aat, als je code post, doe dat dan tussen code tags, dat is het #-symbooltje.
 
Waarom test jij hierop?

Code: 
If ccc <> "" Then

Dat zal nl. toch nooit anders zijn.
 
Wigi zei:
Waarom test jij hierop?

Code: 
If ccc <> "" Then

Dat zal nl. toch nooit anders zijn.
Klik om te vergroten...

Anders wordt een leeg COMMENT aangemaakt. Dat zal wel ergens anders door komen, maar het is wel effectief.

Aat
 
Code: 
Sub TextIntoComments1()
    
    Dim cell As Range
    Dim ccc As String
    Dim sCommentText As String

    For Each cell In Intersect(Selection, ActiveSheet.UsedRange)
    
        With cell
            
            If Len(Trim(.Text)) > 0 Then
            
                ccc = Format(Date, "ddmm") & ": " & .Text
            
                If .Comment Is Nothing Then
                
                    .AddComment.Text ccc
                    
                Else
                    
                    sCommentText = .Comment.Text
                    
                    If InStr(sCommentText, ccc) > 0 Then
                    
                        sCommentText = Replace(sCommentText, ccc, "", 1)
                        
                    End If
                    
                    .Comment.Text ccc & Chr(10) & sCommentText
                    .Comment.Text Replace(.Comment.Text, Chr(10) & Chr(10), Chr(10))
                    
                End If
        
                .Comment.Visible = False
                .Comment.Shape.TextFrame.AutoSize = True
            
            End If
            
        End With

    Next
End Sub

Wigi
 
Wigi zei:
Code: 
Sub TextIntoComments1()
    
    Dim cell As Range
    Dim ccc As String
    Dim sCommentText As String

    For Each cell In Intersect(Selection, ActiveSheet.UsedRange)
    
        With cell
            
            If Len(Trim(.Text)) > 0 Then
            
                ccc = Format(Date, "ddmm") & ": " & .Text
            
                If .Comment Is Nothing Then
                
                    .AddComment.Text ccc
                    
                Else
                    
                    sCommentText = .Comment.Text
                    
                    If InStr(sCommentText, ccc) > 0 Then
                    
                        sCommentText = Replace(sCommentText, ccc, "", 1)
                        
                    End If
                    
                    .Comment.Text ccc & Chr(10) & sCommentText
                    .Comment.Text Replace(.Comment.Text, Chr(10) & Chr(10), Chr(10))
                    
                End If
        
                .Comment.Visible = False
                .Comment.Shape.TextFrame.AutoSize = True
            
            End If
            
        End With

    Next
End Sub

Wigi
Klik om te vergroten...


Is natuurlijk mooier.......

Bedankt...

Aat
 
Wigi zei:
Code: 
Sub TextIntoComments1()
    
    Dim cell As Range
    Dim ccc As String
    Dim sCommentText As String

    For Each cell In Intersect(Selection, ActiveSheet.UsedRange)
    
        With cell
            
            If Len(Trim(.Text)) > 0 Then
            
                ccc = Format(Date, "ddmm") & ": " & .Text
            
                If .Comment Is Nothing Then
                
                    .AddComment.Text ccc
                    
                Else
                    
                    sCommentText = .Comment.Text
                    
                    If InStr(sCommentText, ccc) > 0 Then
                    
                        sCommentText = Replace(sCommentText, ccc, "", 1)
                        
                    End If
                    
                    .Comment.Text ccc & Chr(10) & sCommentText
                    .Comment.Text Replace(.Comment.Text, Chr(10) & Chr(10), Chr(10))
                    
                End If
        
                .Comment.Visible = False
                .Comment.Shape.TextFrame.AutoSize = True
            
            End If
            
        End With

    Next
End Sub

Wigi
Klik om te vergroten...

Kan je mij ook nog vertellen hoe ik de tekst welke in de CEL staat kan overschrijven met de waarde welke in ccc staat?

Mvg,

Aat
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan