Insert Comments that has Changed Only(This is a tough one)

[centaur63]

Ok what i need to do with this code now is make it so that it only inserts the comment that has changed since the last time i ran it. Right now it keeps inserting the same cells over and over again. Can You please help me with this one!!!!

Private Sub PrintCommentsByColumn()
  
  Dim cell As Range
  Dim myrange As Range, myrangeC As Range
  Dim col As Long
  Dim RowOS As Long
  Dim wsSource As Worksheet
  Dim wsNew As Worksheet
  If ActiveSheet.Comments.Count = 0 Then
    MsgBox "No comments in entire sheet"
    Exit Sub
  End If
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Set wsSource = ActiveSheet
  Sheets.Add
  Set wsNew = ActiveSheet
  wsSource.Activate
  With wsNew.Columns("A:D")
      .VerticalAlignment = xlTop
      .WrapText = True
  End With
  wsNew.Columns("B").ColumnWidth = 15
  wsNew.Columns("C").ColumnWidth = 15
  wsNew.Columns("D").ColumnWidth = 60
  wsNew.PageSetup.PrintGridlines = True
  RowOS = 2
  wsNew.Cells(1, 4) = "'" & Application.ActiveWorkbook.FullName & " -- " & _
      Application.ActiveSheet.Name
  For col = 1 To ActiveSheet.UsedRange.Columns.Count
     Set myrangeC = Intersect(ActiveSheet.UsedRange, Columns(col), _
         Cells.SpecialCells(xlCellTypeComments))
     If myrangeC Is Nothing Then GoTo nxtCol
     For Each cell In myrangeC
        If Trim(cell.Comment.Text) <> "" Then
           RowOS = RowOS + 1
           wsNew.Cells(RowOS, 1) = "'" & cell.Address(0, 0) & ":"
           wsNew.Cells(RowOS, 2) = "'" & Date & "     " & Time
           wsNew.Cells(RowOS, 3) = "'" & cell.Text
           wsNew.Cells(RowOS, 4) = "'" & cell.Comment.Text
        End If
     Next cell
nxtCol:
  Next col
  wsNew.Activate
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

 

[erik.van.geit]

feel free to get a little nervous
after all those replies, this will be very close to what you need

Option Explicit

Private Sub PrintCommentsByColumn()
  
Dim wsSource As Worksheet
Dim wsNew As Worksheet
Dim cell As Range
Dim myUsedRange As Range
Dim myrangeC As Range
Dim col As Long
Dim RowOS As Long
Dim c As Range


    If ActiveSheet.Comments.Count = 0 Then
    MsgBox "No comments in active sheet", 48, "END CODE"
    Exit Sub
    End If
    
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wsSource = ActiveSheet
Set myUsedRange = wsSource.UsedRange
Set wsNew = Sheets("Test")


    With wsNew
        With .Columns("A:D")
        .VerticalAlignment = xlTop
        .WrapText = True
        End With
    .Columns("B").ColumnWidth = 15
    .Columns("C").ColumnWidth = 15
    .Columns("D").ColumnWidth = 60
    .PageSetup.PrintGridlines = True
    .Cells(1, 4) = ActiveWorkbook.FullName & " -- " & wsSource.Name
    
        RowOS = wsNew.Cells(Rows.Count, "A").End(xlUp)(2).Row
        For col = 1 To myUsedRange.Columns.Count
        Set myrangeC = Intersect(myUsedRange, wsSource.Columns(col), wsSource.Cells.SpecialCells(xlCellTypeComments))
        
            If Not myrangeC Is Nothing Then
                For Each cell In myrangeC
                Set c = Nothing
                Set c = .Columns(1).Find(cell.Address(0, 0), LookIn:=xlValues, lookat:=xlWhole)
                On Error Resume Next
                    If c Is Nothing Or Not c Is Nothing And c.Offset(0, 3) <> cell.Comment.Text Then
                        If Trim(cell.Comment.Text) <> "" Then
                        RowOS = RowOS + 1
                        .Cells(RowOS, 1) = "'" & cell.Address(0, 0)
                        .Cells(RowOS, 2) = "'" & Date & "     " & Time
                        .Cells(RowOS, 3) = "'" & cell.Text
                        .Cells(RowOS, 4) = "'" & cell.Comment.Text
                        End If
                    End If
                Next cell
            End If

        Next col
    .Activate
    .Range("A3:D" & RowOS).Sort key1:=.Range("A3"), order1:=xlAscending
    End With


Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

 

[centaur63]

Option Explicit

...

 

[centaur63]

Thank You

That was excatly what i was looking for. Thank You so much for your time. I just have one last question for you. Is there a way i can make this run with out manually running this????

 

[erik.van.geit]

Re: Option Explicit

Does that belong at the beginning or end of this program. "Option Explicit"

see the helpfiles for Option Explicit

it is so useful the goal is to force declaration of variables
this way you can avoid a lot of errors (typos, but also others)

 

[centaur63]

Thank You

Thanks Again For all your help and patience with me.

 

[erik.van.geit]

Re: Thank You

That was excatly what i was looking for. Thank You so much for your time. I just have one last question for you. Is there a way i can make this run with out manually running this????

you mean sheetevents ?

as this could be a timeconsuming macro, I wouldn't launch this on every sheetchange
perhaps when opening the workbook and when activating the Testsheet: then the sheetname must be hardcoded too
like

Set wsSource = Sheets("Sheet1")

in thisworkbook

Private Sub Workbook_Open()
PrintCommentsByColumn
End Sub

in "Test" sheetmodule

Private Sub Worksheet_Activate()
PrintCommentsByColumn
End Sub

is this what you want ?

 

[centaur63]

Would It Be easier

Im sorry I am not understanding. Would it be easier to have this macro run when the workbook is closed or opened???

 

[erik.van.geit]

Re: Would It Be easier

Im sorry I am not understanding. Would it be easier to have this macro run when the workbook is closed or opened???

perhaps is was me who misunderstood your question

Is there a way i can make this run with out manually running this

don't you want to run the code without you needing to push a button ?

when would you want to run it ?
it's up to you to choose

 

[centaur63]

Code

I want it to run when i open the workbook. Is that possible?

 

[erik.van.geit]

yes!!
as posted previously

Private Sub Workbook_Open() 
PrintCommentsByColumn 
End Sub

TO INSTALL IN THISWORKBOOK CODE WINDOW:
1. Rightclick the little Excel-icon on the topleft of your page just beside the Filemenu
2. Select "View Code" in drop down menu
3. VBE window will open ... paste code in and exit VBE
don't forget to hardcode the sheetname
like

Set wsSource = Sheets("Sheet1")