Macro to check if data has changed and append to another cell

[brigitteMogg]

Could you provide me with help with creating a macro to do the following please?

1. If user wishes to change the date in Column B the date currently held in column B needs to append to the data in Column C and is formatted with strikethrough.
2. If user wants to change the estimate in Column D the original estimate needs to append to data in Column E and is formatted with striokegthrough
3. If user changes the status of the project to Complete a message box appears to ask for the completed data and this is copied into column I
4. Once user has added the completion date the whole range from a-I is copied into the complete worksheet and added to next available blank line.
5. Once all data has been update I want to copy the range a2:I??end , open a word template and copy it into the bookmark area projects.

[OllieB]

brigitte,

all steps but the last one.

add the following routines to the worksheet Data

Private Sub Worksheet_Change(ByVal Target As Range)
     If Target.Column = 2 Then
          Application.EnableEvents = False
          Call ChangedPublishDate(Target)
          Application.EnableEvents = True
     ElseIf Target.Column = 4 Then
          Application.EnableEvents = False
          Call ChangedEstimate(Target)
          Application.EnableEvents = True
     ElseIf Target.Column = 7 Then
          If Target.Value = "Complete" Then
               Application.EnableEvents = False
               Call CompleteProject(Target)
               Application.EnableEvents = True
          End If
     End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
     If Target.Column = 2 Then
          pubCellBValue = ActiveCell.Value
     ElseIf Target.Column = 4 Then
          pubCellDValue = ActiveCell.Value
     End If
End Sub

create a new module, and insert the following code

Option Explicit

'#
'# declare a public variable that holds the content of the cells in the B and D columns when the user moves the
'# cursor to either column to make a change - the value in either variable is updated by a worksheet_selection_change
'# event
'#
     Public pubCellBValue As String
     Public pubCellDValue As Long
     
'##################################################################################################
'# routine to process changes made to the published date shown in column B - this routine is triggered by the
'# worksheet_change event in case of a change made to any cell in column B
'##################################################################################################
     Public Sub ChangedPublishDate(ByRef rngTarget As Excel.Range)
     '#
     '# declare
     '#
          Dim intTextLength As Integer
     '#
     '# if the public variable pubCellBvalue holds a value then this value represents the previous value
     '# held in the cell before a user made a change - this value must be appended to the value in column
     '# C for the current row
     '#
          If LenB(pubCellBValue & "") > 0 Then
               intTextLength = Len(ActiveSheet.Cells(rngTarget.Row, "C").Value)
               ActiveSheet.Cells(rngTarget.Row, "C").Value = ActiveSheet.Cells(rngTarget.Row, "C").Value & vbLf & pubCellBValue
               ActiveSheet.Cells(rngTarget.Row, "C").Characters(intTextLength + 1, Len(pubCellBValue)).Font.Strikethrough = True
               pubCellBValue = vbNullString
          End If
     End Sub
'##################################################################################################
'# routine to process changes made to the estimate shown in column D - this routine is triggered by the
'# worksheet_change event in case of a change made to any cell in column D
'##################################################################################################
     Public Sub ChangedEstimate(ByRef rngTarget As Excel.Range)
     '#
     '# declare
     '#
          Dim intTextLength As Integer
     '#
     '# if the public variable pubCellBvalue holds a value then this value represents the previous value
     '# held in the cell before a user made a change - this value must be appended to the value in column
     '# C for the current row
     '#
          If pubCellDValue > 0 Then
               intTextLength = Len(ActiveSheet.Cells(rngTarget.Row, "E").Value)
               ActiveSheet.Cells(rngTarget.Row, "E").Value = ActiveSheet.Cells(rngTarget.Row, "E").Value & vbLf & pubCellDValue
               ActiveSheet.Cells(rngTarget.Row, "E").Characters(intTextLength + 1, Len(pubCellDValue)).Font.Strikethrough = True
               pubCellDValue = 0
          End If
     End Sub
'##################################################################################################
'# routine to process a project being reported as complete - this routine is triggered by the
'# worksheet_change event in case of a change made to any cell in column G where the selected value equals 'Complete'
'##################################################################################################
     Public Sub CompleteProject(ByRef rngTarget As Excel.Range)
     '#
     '# declare
     '#
          Dim strCompletionDate As String
     '#
     '# prompt the user for a completion date
     '#
          strCompletionDate = Application.InputBox("Please specifiy completion date", "Complete", Format$(Now(), "dd/mm/yyyy"), , , , , 2)
          If Not IsDate(strCompletionDate) Then
               MsgBox "No valid date provided"
          End If
     '#
     '# store the completion date
     '#
          rngTarget.Offset(, 2).Value = DateValue(strCompletionDate)
     '#
     '# move the row onto the complete worksheet
     '#
          rngTarget.Parent.Rows(rngTarget.Row).Copy ThisWorkbook.Worksheets("Complete").Cells(Rows.Count, "A").End(xlUp).Offset(1)
          rngTarget.Parent.Rows(rngTarget.Row).Delete
     End Sub

[brigitteMogg]

Hi Ollie, this is absolutely brilliant and does everything I asked for. Thank you very much you are a star.

I have just taken out the line 'rngTarget.Parent.Rows(rngTarget.Row).Delete' because I want to keep this data for that reporting period but then want to delete it the following month. Therefore I need another routiune that checks on opening the workbook if the completed project on the data worksheet has been copied into the complete worksheet and deletes the project data from the data worksheet. Do you have any ideas?

[OllieB]

I think you are better off using a button that, when clicked by the user, removes all project rows with a completion date in the previous month (as determined by the current date) after asking the user whether he/she is really sure. The routine below can be linked to such a command button, or can be called from within the workbook_open event. Up to you :-)

'##################################################################################################
'# this routine is triggered by the user via a command_button to remove all projects from the data worksheet, where
'# the completion month < prior month and the project is found on the Complete worksheet
'##################################################################################################
     Public Sub RemoveCompletedProjects()
     '#
     '# declare
     '#
          Dim xlsDATA As Excel.Worksheet
          Dim xlsCOMPLETE As Excel.Worksheet
          Dim lngRowNumber As Long
          Dim lngInnerLoop As Long
          Dim flgArchived As Boolean
          Dim intResponse As VbMsgBoxResult
     '#
     '# ask the user for a confirmation
     '#
          intResponse = MsgBox("Are you sure you want to remove completed projects from the data worksheet?", vbYesNo, "Confirm")
          If intResponse <> vbYes Then
               Exit Sub
          End If
     '#
     '# disable event processing because we are going to delete some rows
     '# from the data worksheet
     '#
          Application.EnableEvents = False
     '#
     '# loop for all completed projects and check whether the completion date lies in the previous month, if
     '# yes, check that the project also exists on the Complete worksheet before it is actually removed
     '#
          Set xlsDATA = ThisWorkbook.Worksheets("Data")
          Set xlsCOMPLETE = ThisWorkbook.Worksheets("Complete")
     
          With xlsDATA
               For lngRowNumber = .Cells(.Rows.Count, "A").End(xlUp).Row To 1 Step -1
               '# if status complete
                    If .Cells(lngRowNumber, "G").Value = "Complete" Then
                    '# if completed in the previous month
                         If Format(.Cells(lngRowNumber, "I").Value, "yyyymm") < Format(Now(), "yyyymm") Then
                         '# if present on complete worksheet
                              flgArchived = False
                              With xlsCOMPLETE
                                   For lngInnerLoop = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
                                        If .Cells(lngInnerLoop, "A").Value = xlsDATA.Cells(lngRowNumber, "A").Value Then
                                             flgArchived = True
                                             Exit For
                                        End If
                                   Next lngInnerLoop
                              End With
                         '# if found on complete worksheet, delete row
                              .Rows(lngRowNumber).Delete
                         End If
                    End If
               Next lngRowNumber
          End With
     '#
     '# restore event handling
     '#
          Application.EnableEvents = True
     End Sub

[brigitteMogg]

Again, this works brilliantly, and I agree, adding it to a button is better solution.

With regard to opening a word template and then copying this data across. Although I have had some replies, none of them have worked, whereas yours have worked first time.

Thank you

[OllieB]

If you want assistance on the export to Word please provide a copy of the Word document and a description of what you would like to happen.

[brigitteMogg]

Thank you Olli. I have added a copy of the word document that is created when opening a new document from my template. I am unable to upload the template for you to see as ti doesn't accept the file extension. Below is what I want to achieve:

1. Once the user has finished updating their report I want them to press a button, which opens a new word document from a template called "monthly report.dotm" from their 'my template' area
2. I then want it to copy the data from the worksheet "data" from within the sample workbook you have been working with. Goto the bookmark "projects" in the new word doument and paste the data range.

I hope this is clear enough for you

Brigitte

[OllieB]

Please post the template in a zip file (that is allowed) and I will have a go at writing a solution for you

[brigitteMogg]

Hi Ollie, that would be absolutely fantastic. I have therefore attached a zip file with the template in.

[brigitteMogg]

Hi Ollie, I have transferred the excel workbook to another laptop and I am now getting an error message ' cannot find project or library'. Do you have any suggestions on how to resolve this?

[OllieB]

brigitte, I noticed that there are some special project references which also prevented me from compiling any code. Hence I have only posted the code as text and did not include any workbook to you. Go to Tools/Reference and "deselect" those references with a text MISSING:. That should solve your problem as I do not think you require them. I will try to work on your document export this weekend.

[OllieB]

I just noticed you wanted to paste the table on the data worksheet. Revised code below

'##################################################################################################
'# this routine is triggered by the user via a command_button to export details of completed projects to a
'# Word document opened by the user
'##################################################################################################
     Public Sub ExportCompletedProjects()
     '#
     '# declare
     '#
          Dim xlsCOMPLETE As Excel.Worksheet
          Dim lngRowNumber As Long
          Dim appWord As Word.Application
          Dim docEXPORT As Word.Document
          Dim docSelection As Word.Selection
          Dim strDocumentName As String
     '#
     '# create an instance of Word and attempt to open the selected document
     '#
          Set appWord = New Word.Application
          Set docEXPORT = appWord.Documents.Add(ThisWorkbook.Path & "\Monthly Report.dotm", , , True)
          Set docSelection = appWord.Selection
          If docEXPORT Is Nothing Then
               MsgBox "An error occured while creating a new document based on Monthly Report.dotm, process aborted", vbCritical, "ERROR"
               Exit Sub
          End If
    '#
     '# move the document selection to the projects bookmark
     '#
          appWord.Selection.Goto What:=wdGoToBookmark, Name:="Projects"
     '#
     '# copy & paste the range holding all projects
     '#
          With ThisWorkbook.Worksheets("Data")
               lngRowNumber = .Cells(.Rows.Count, "A").End(xlUp).Row
               .Cells(1, "A").Resize(lngRowNumber, 9).Copy
               appWord.Selection.Paste
          End With
     '#
     '# prompt for saving the document
     '#
          appWord.Visible = True
          appWord.Dialogs(wdDialogFileSaveAs).Show
     '#
     '# housekeeping
     '#
          Set docEXPORT = Nothing
          Set docSelection = Nothing
          Set appWord = Nothing
     End Sub

[OllieB]

brigitte, we never really discussed what you would like to have written into the Projects bookmark section of the Word template so I have just provided the framework below. It should be quite easy to expand on. Perhaps by adding a table to the Projects section and filling that in. Note that the code assumes that the document template will be available in the same directory as the workbook itself.

Try this

'##################################################################################################
'# this routine is triggered by the user via a command_button to export details of completed projects to a
'# Word document opened by the user
'##################################################################################################
     Public Sub ExportCompletedProjects()
     '#
     '# declare
     '#
          Dim xlsCOMPLETE As Excel.Worksheet
          Dim lngRowNumber As Long
          Dim appWord As Word.Application
          Dim docEXPORT As Word.Document
          Dim docSelection As Word.Selection
          Dim strDocumentName As String
     '#
     '# create an instance of Word and attempt to open the selected document
     '#
          Set appWord = New Word.Application
          Set docEXPORT = appWord.Documents.Add(ThisWorkbook.Path & "\Monthly Report.dotm", , , True)
          Set docSelection = appWord.Selection
          If docEXPORT Is Nothing Then
               MsgBox "An error occured while creating a new document based on Monthly Report.dotm, process aborted", vbCritical, "ERROR"
               Exit Sub
          End If
    '#
     '# move the document selection to the projects bookmark
     '#
          appWord.Selection.Goto What:=wdGoToBookmark, Name:="Projects"
     '#
     '# process all records from the Complete worksheet
     '#
          With ThisWorkbook.Worksheets("Complete")
               For lngRowNumber = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
                    docSelection.TypeText Text:=.Cells(lngRowNumber, "A").Value & vbTab & .Cells(lngRowNumber, "I").Value
                    docSelection.TypeParagraph
               Next lngRowNumber
          End With
     '#
     '# prompt for saving the document
     '#
          appWord.Visible = True
          appWord.Dialogs(wdDialogFileSaveAs).Show
     '#
     '# housekeeping
     '#
          Set docEXPORT = Nothing
          Set docSelection = Nothing
          Set appWord = Nothing
     End Sub

[OllieB]

Hi Brigitte, is this solution working for you?

[brigitteMogg]

Hi Ollie

Sorry I haven't replied to your messages, unfortunately my husband died at the end of January and I have only just returned to work. I have a few changes to my spreadsheet that I would like some help with, would you be able to look at these for me?

Brigitte

[brigitteMogg]

Could I have some assistance in making the cell bold in Column B when date has been changed and has been copied across to column C?