udskrift af kommentarer

Et bud:
Rem Kode anbringes i ThisWorkbook (VBA) - (Alt+F11)
Rem Ark1 undersøges for kommentarer
Rem Ark2 indeholder adresse + kommentar
Rem ===================================
Dim ræk2
Sub activeworkbook_activate()
Dim komm As Comment
    ActiveWorkbook.Sheets(1).Activate
    ræk2 = 1
       
    For Each komm In ActiveSheet.Comments
        adresse = komm.Parent.Address
        tekst = komm.Text
       
        With ActiveWorkbook.Sheets(2)
            .Cells(ræk2, 1) = CStr(adresse)
            .Cells(ræk2, 2) = tekst
            ræk2 = ræk2 + 1
        End With
    Next komm
   
    With ActiveWorkbook.Sheets(2)
        .Columns.AutoFit
    End With
End Sub

haløj supertekst - den er næsten perfekt, blot kunne jeg tænke mig at det er cellens indhold og ikke adresse som angives. Kan du fikse de?

Rem Kode anbringes i ThisWorkbook (VBA) - (Alt+F11)
Rem Ark1 undersøges for kommentarer
Rem Ark2 indeholder indhold + kommentar
Rem ===================================
Dim antalRæk, antalKol, ræk2
Sub activeworkbook_activate()
Dim komm As Comment
    ActiveWorkbook.Sheets(1).Activate
    ræk2 = 1
       
    For Each komm In ActiveSheet.Comments
        adresse = komm.Parent.Address
        tekst = komm.Text
        indhold = Range(adresse).Value
       
        With ActiveWorkbook.Sheets(2)
            .Cells(ræk2, 1) = indhold
            .Cells(ræk2, 2) = tekst
            ræk2 = ræk2 + 1
        End With
    Next komm
   
    With ActiveWorkbook.Sheets(2)
        .Columns.AutoFit
    End With
End Sub

Hej supertekst

off topic:
hvis jeg nu har 12 ark med bemærkninger og ønsker at samle dem i ark 13, hvorledes gør man det.

giver gerne points :-)

Skulle ikke være noget problem - vender tilbage.....

Bemærk - arket, der "samler kommentarer" er navngivet - men kan ajourføres!
Rem Kode anbringes i ThisWorkbook (VBA) - (Alt+F11)
Rem Ark1 undersøges for kommentarer
Rem Ark2 indeholder indhold + kommentar
Rem Version 2 11/1-2007
Rem ===================================
Const kArk = "Kommentarer"                          'Navn på kommentarArk, kan ajourføres

Dim antalRæk, antalKol, ræk2
Sub activeworkbook_activate()
Dim komm As Comment
    ActiveWorkbook.Sheets(1).Activate
    ræk2 = 1
       
Rem søg igennem alle ark
    For Each ark In ActiveWorkbook.Sheets
        For Each komm In ark.Comments
            adresse = komm.Parent.Address
            tekst = komm.Text
            indhold = ark.Range(adresse).Value
           
            With ActiveWorkbook.Sheets(kArk)
                .Cells(ræk2, 1) = indhold
                .Cells(ræk2, 2) = tekst
                ræk2 = ræk2 + 1
            End With
        Next komm
    Next
   
    With ActiveWorkbook.Sheets(kArk)
        .Columns.AutoFit
    End With
   
    MsgBox ("Kommentarer er hentet")
    ActiveWorkbook.Sheets(kArk).Activate
End Sub

Hej Supertekst
Det ser jo godt ud :o)
Kan man sortere lidt i kommentaren, således at navnet på den person, som har indtastet kommentaren ikke udskrives?
mvh / hubertus

Ja - det er første linie, der skal slettes - vender tilbage.......

Rem Kode anbringes i ThisWorkbook (VBA) - (Alt+F11)
Rem Ark1 undersøges for kommentarer
Rem Ark2 indeholder indhold + kommentar
Rem Version 3 11/1-2007 - fjerner 1. linie i kommentar (Bruger)
Rem ===========================================================
Const kArk = "Kommentarer"                          'Navn på kommentarArk, kan ajourføres
Dim antalRæk, antalKol, ræk2
Sub activeworkbook_activate()
Dim komm As Comment
    ActiveWorkbook.Sheets(1).Activate
    ræk2 = 1
       
Rem søg igennem alle ark
    For Each ark In ActiveWorkbook.Sheets
        For Each komm In ark.Comments
            adresse = komm.Parent.Address
            tekst = fjernLinie1(komm.Text)
            indhold = ark.Range(adresse).Value
           
            With ActiveWorkbook.Sheets(kArk)
                .Cells(ræk2, 1) = indhold
                .Cells(ræk2, 2) = tekst
                ræk2 = ræk2 + 1
            End With
        Next komm
    Next
   
    With ActiveWorkbook.Sheets(kArk)
        .Columns.AutoFit
    End With
   
    MsgBox ("Kommentarer er hentet")
    ActiveWorkbook.Sheets(kArk).Activate
End Sub
Private Function fjernLinie1(kommentar)
    p = InStr(kommentar, Chr(10))
    If p > 0 Then
        fjernLinie1 = Mid(kommentar, p + 1)
    Else
        fjernLinie1 = kommentar
    End If
End Function

hvis jeg må blande mig lidt igen, kan man så også udelade en kommentar, hvis den indeholder en dato af formen 09-09-06? kan du løse det er der point på vej.

bare til orientering richter1 er en kollega, som jeg samarbejder med.

Dato - det tror jeg nok - idet der kan testes på
if Isdate(indhold)= true then
.."ingen opdatering.."
end if

Tester det fredag - hvis du ikke selv forsøger - giv blot signal

Hubertus - det er ok

Hvis jeg gerne vil have værdien for cellen i kolonne A med over, hvordan gør vi lige det?

Mener du følgende:
For hver kommenta, der skal overføres medtages værdien i kolonne A i samme række, som kommentaren er placeret i?
Hvor skal denne værdi placeres på "Kommentar"-arket - i separat celle - samme række?

isdate er lidt problematisk, da 09-08-06 jo bare er en tekst og ikke formateret som en dato.
mvh.
hubertus

Ja, netop. I samme række.

hubertus: vedr. dato - afprøver det. Kan der være anført anden tekst i en kommentar med dato?

Ja, der er anden tekst i kommentaren, bla. et ord (nase), som jeg senere skal have selekteret ud.

Problemet med dato:
Opfattede det i første omgang som, hvis dato i cellen og ikke i kommentaren, selvom I havde skrevet det korrekt. I første omgang er er dette løst ved at indsætte kommentarteksten i en celle på kommentararket og så teste med IsDate. Det virker.

Nu vil jeg så "scanne" teksten i kommentaren og test om der er en dato heri.

Indhold i KolonneA er løst.
-
"bla. et ord (nase), som jeg senere skal have selekteret ud" - hvad mener du med dette?

Rem Kode anbringes i ThisWorkbook (VBA) - (Alt+F11)
Rem Ark1 undersøges for kommentarer
Rem "Kommentarer" indhold + kommentar
Rem BrugerInitialer fjernes
Rem Kommentarer kun med dato/ dato + tekst medtages ikke
Rem Indhold fra Kolonne A/kommentarrække medtages
Rem Version 12/1-2007
Rem =====================================================
Const kArk = "Kommentarer"                          'Navn på kommentarArk, kan ajourføres
Dim antalRæk, antalKol, ræk2
Sub activeworkbook_activate()
Dim komm As Comment
    ActiveWorkbook.Sheets(1).Activate
    ræk2 = 1
       
Rem søg igennem alle ark
    For Each ark In ActiveWorkbook.Sheets
        For Each komm In ark.Comments
            adresse = komm.Parent.Address          'kommentarens adresse
            tekst = fjernLinie1(komm.Text)          '-  tekst
            indhold = ark.Range(adresse).Value      'kommentarcellens indhold
            kommentarræk = Range(adresse).Row
            kolonneA = ark.Cells(kommentarræk, 1)  'indhold i kolonne A - kommentarens række

            If scanOmDato(tekst) = False Then
                With ActiveWorkbook.Sheets(kArk)
                    .Cells(ræk2, 1) = indhold
                    .Cells(ræk2, 2) = tekst
                    .Cells(ræk2, 3) = kolonneA
                    ræk2 = ræk2 + 1
                End With
            End If
        Next komm
    Next
   
    With ActiveWorkbook.Sheets(kArk)
        .Columns.AutoFit
    End With
   
    MsgBox ("Kommentarer er hentet")
    ActiveWorkbook.Sheets(kArk).Activate
End Sub
Private Function scanOmDato(t)
Dim part
Rem test kun hvis længden >= 8 tegn
    If Len(t) >= 8 Then
        For f = 1 To Len(t)
            part = Mid(t, f, 8)
            If testOmDato(part) = True Then
                scanOmDato = True
                Exit Function
            End If
        Next f
    End If
   
    scanOmDato = False
End Function
Private Function testOmDato(t)
    With ActiveWorkbook.Sheets(kArk)        'anvender ræk 1/kol 50 til test
        .Cells(1, 50) = t
        If IsDate(.Cells(1, 50)) = True Then
            testOmDato = True
        Else
            testOmDato = False
        End If
        .Cells(1, 50) = ""
    End With
End Function
Private Function fjernLinie1(kommentar)
    p = InStr(kommentar, Chr(10))
    If p > 0 Then
        fjernLinie1 = Mid(kommentar, p + 1)
    Else
        fjernLinie1 = kommentar
    End If
End Function

ang. ordet nase, så har jeg brug for at få de kommentarer hvori ordet nase indgår skrevet på et separat ark, da de har en særlig betydning.

supertekst ->
se her: http://www.eksperten.dk/spm/755568

OK & tak - her kommer nyeste version "m/nase"
Obs. bemærk nyt ark oprettet med navnet Nase
---------------------------------------------
Rem Kode anbringes i ThisWorkbook (VBA) - (Alt+F11)
Rem Ark1 undersøges for kommentarer
Rem "Kommentarer" indhold + kommentar
Rem BrugerInitialer fjernes
Rem Kommentarer kun med dato medtages ikke
Rem Indhold fra Kolonne A/kommentarrække medtages
Rem Version 12/1-2007
Rem =============================================
Const kArk = "Kommentarer"                          'Navn på kommentarArk, kan ajourføres
Const nArk = "Nase"                                'Kommentarer med "nase" indsættes på dette ark
Dim antalRæk, antalKol, rækK, rækN
Sub activeworkbook_activate()
Dim komm As Comment, kArkNavn, kArkRække, nFlag As Boolean
    ActiveWorkbook.Sheets(1).Activate
    rækK = 1
    rækN = 1
   
Rem søg igennem alle ark
    For Each ark In ActiveWorkbook.Sheets
        For Each komm In ark.Comments
            adresse = komm.Parent.Address          'kommentarens adresse
            tekst = fjernLinie1(komm.Text)          '-  tekst
            indhold = ark.Range(adresse).Value      'kommentarcellens indhold
            kommentarræk = Range(adresse).Row
            kolonneA = ark.Cells(kommentarræk, 1)  'indhold i kolonne A - kommentarens række
           
Rem indeholder kommentaren ordet "nase"
            If InStr(LCase(tekst), "nase") > 0 Then
                kArkNavn = nArk
                kArkRække = rækN
                nFlag = True
            Else
                kArkNavn = kArk
                kArkRække = rækK
                nFlag = False
            End If
                       
            If scanOmDato(tekst) = False Then
                With ActiveWorkbook.Sheets(kArkNavn)
                    .Cells(kArkRække, 1) = indhold
                    .Cells(kArkRække, 2) = tekst
                    .Cells(kArkRække, 3) = kolonneA
                   
                    If nFlag = True Then
                        rækN = rækN + 1
                    Else
                        rækK = rækK + 1
                    End If
                End With
            End If
        Next komm
    Next
   
    With ActiveWorkbook.Sheets(kArk)
        .Columns.AutoFit
    End With
   
    With ActiveWorkbook.Sheets(nArk)
        .Columns.AutoFit
    End With
   
    MsgBox ("Kommentarer er hentet")
    ActiveWorkbook.Sheets(kArk).Activate
End Sub
Private Function scanOmDato(t)
Dim part
Rem test kun hvis længden >= 8 tegn
    If Len(t) >= 8 Then
        For f = 1 To Len(t)
            part = Mid(t, f, 8)
            If testOmDato(part) = True Then
                scanOmDato = True
                Exit Function
            End If
        Next f
    End If
   
    scanOmDato = False
End Function
Private Function testOmDato(t)
    With ActiveWorkbook.Sheets(kArk)        'anvender ræk 1/kol 50 til test
        .Cells(1, 50) = t
        If IsDate(.Cells(1, 50)) = True Then
            testOmDato = True
        Else
            testOmDato = False
        End If
        .Cells(1, 50) = ""
    End With
End Function
Private Function fjernLinie1(kommentar)
    p = InStr(kommentar, Chr(10))
    If p > 0 Then
        fjernLinie1 = Mid(kommentar, p + 1)
    Else
        fjernLinie1 = kommentar
    End If
End Function

Hej igen - tilbage på pinden.
Jeg har testet ovenstående uden held med hensyn til de kommentarer der indeholder ordet nase. Er det fordi de er af formen: NaseE9-1234? En hel kommentar kan f.eks. se således ud: NaseE9-6658 MIDDAGSLÆS. Alt hvad der står efter 6658 skal væk.

Der testes på om "nase" findes i kommentarteksten og denne kommentar placeres på det særlige ark.
Når der skal fjernes noget af kommentarteksten - er det du skriver så entydigt: NaseE9-9999 TEKST, således at alt efter den blanke skal slettes?

Det var også min opfattelse, men der kommer bare ikke noget på nase arket. Kommentararket virker fint. Teksten kan variere, men blanktegnet kan bruges til at adskille med.

Jeg kan godt "fange" Nase..... - prøv at sende en kopi af din XLS-fil til: pb@supertekst-it.dk

arket er afsendt

Her er så et svar...