Copy and PasteSpecialValues of within a User-Defined Function

[BigShanny]

I have a user defined function that calculates the current date if the value of another cell (FileName) is not "". In other words, when someone updates a new file name, the date of when they did the update auto-populates. Once this value is calculated, I would like to copy and paste it's value only (PasteSpecial Values) back into the same cell. Essentially, once the value is calculated, I want to kill the formula so that it cannot be used again. I just want the initial calculated value to remain. I've tried calling a sub-routine (Hardcode) with no luck. I'm honestly not sure if this is the best approach. Even if it is, I can't seem to get the syntax correct. Any thoughts on the most efficient way to accomplish my desired task?

Function LoadDate(FileName As String)

    
    If (FileName <> "") Then
    
        LoadDate = Date
        Call Hardcode (LoadDate)
                
    Else
        
        LoadDate = ""
            
    End If
    
            
      
End Function

Sub HardCode(LoadDate As Date)

Range(LoadDate).Copy
Range(LoadDate).PasteSpecial xlPasteValuesAndNumberFormats


End Sub

 

[BigShanny]

This works exactly as you describe. Column D will be updated all at once so that poses a problem, but I might be able to re-work our process for that field. The other fields in the scope of the project are updated one at a time so I'll retool your code with new "case clauses" to accommodate them.

Perhaps this should be another post but.....

Through this process, I discovered something that makes my heart sink. I have another change routine that must remain attached to the same sheet. It is code that allows a user to select multiple items from a drop-down list. I just learned that I can't have multiple change routines tied to a sheet. I'm at a loss for how to overcome this. t was all just copied from one of the help boards (maybe even this one) about a year ago. It's worked great up until this point. I've seen a few examples of combining 2 subs into one to overcome this problem but it would be way over my head in this case. I somehow need to combine the code you helped me with and the "multiple drop-down" code. Here's the code if you have any ideas.

Private Sub Worksheet_Change(ByVal Destination As Range)
Dim rngDropdown As Range
Dim oldValue As String
Dim newValue As String
Dim DelimiterType As String
DelimiterType = ", "
Dim DelimiterCount As Integer
Dim TargetType As Integer
Dim i As Integer
Dim arr() As String

 
If Destination.Count > 1 Then Exit Sub
On Error Resume Next
 
Set rngDropdown = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitError
 
If rngDropdown Is Nothing Then GoTo exitError
 
TargetType = 0
    TargetType = Destination.Validation.Type
    If TargetType = 3 Then  ' is validation type is "list"
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        newValue = Destination.Value
        Application.Undo
        oldValue = Destination.Value
        Destination.Value = newValue
        If oldValue <> "" Then
            If newValue <> "" Then
                If oldValue = newValue Or oldValue = newValue & Replace(DelimiterType, " ", "") Or oldValue = newValue & DelimiterType Then ' leave the value if there is only one in the list
                    oldValue = Replace(oldValue, DelimiterType, "")
                    oldValue = Replace(oldValue, Replace(DelimiterType, " ", ""), "")
                    Destination.Value = oldValue
                ElseIf InStr(1, oldValue, DelimiterType & newValue) Or InStr(1, oldValue, newValue & DelimiterType) Or InStr(1, oldValue, DelimiterType & newValue & DelimiterType) Then
                    arr = Split(oldValue, DelimiterType)
                If Not IsError(Application.Match(newValue, arr, 0)) = 0 Then
                    Destination.Value = oldValue & DelimiterType & newValue
                        Else:
                    Destination.Value = ""
                    For i = 0 To UBound(arr)
                    If arr(i) <> newValue Then
                        Destination.Value = Destination.Value & arr(i) & DelimiterType
                    End If
                    Next i
                Destination.Value = Left(Destination.Value, Len(Destination.Value) - Len(DelimiterType))
                End If
                ElseIf InStr(1, oldValue, newValue & Replace(DelimiterType, " ", "")) Then
                    oldValue = Replace(oldValue, newValue, "")
                    Destination.Value = oldValue
                Else
                    Destination.Value = oldValue & DelimiterType & newValue
                End If
                Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", "") & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", "")) ' remove extra commas and spaces
                Destination.Value = Replace(Destination.Value, DelimiterType & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", ""))
                If Destination.Value <> "" Then
                    If Right(Destination.Value, 2) = DelimiterType Then  ' remove delimiter at the end
                        Destination.Value = Left(Destination.Value, Len(Destination.Value) - 2)
                    End If
                End If
                If InStr(1, Destination.Value, DelimiterType) = 1 Then ' remove delimiter as first characters
                    Destination.Value = Replace(Destination.Value, DelimiterType, "", 1, 1)
                End If
                If InStr(1, Destination.Value, Replace(DelimiterType, " ", "")) = 1 Then
                    Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", ""), "", 1, 1)
                End If
                DelimiterCount = 0
                For i = 1 To Len(Destination.Value)
                    If InStr(i, Destination.Value, Replace(DelimiterType, " ", "")) Then
                        DelimiterCount = DelimiterCount + 1
                    End If
                Next i
                If DelimiterCount = 1 Then ' remove delimiter if last character
                    Destination.Value = Replace(Destination.Value, DelimiterType, "")
                    Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", ""), "")
                End If
            End If
        End If
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
 
exitError:
  Application.EnableEvents = True
End Sub

 

[Joe4]

OK, here is my the amendment to my last code that will work on multiple cells being updated at once:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng As Range
    Dim cell As Range
    Dim r As Long
    Dim c As Long
   
    Application.ScreenUpdating = False
    Application.EnableEvents = False
   
'   Set range to encompass all columns we need to watch
    Set rng = Intersect(Target, Columns("D:I"))

'   Exit if no cells round
    If rng Is Nothing Then Exit Sub
   
'   Loop through all cells updated in watched range
    For Each cell In rng
'       Get row and column of update
        r = cell.Row
        c = cell.Column
'       Exclude row 1
        If r > 1 Then
'           See which column was just updated
            Select Case c
'               If column D (4th column)
                Case 4
'                   Check to see if column F is empty
                        If Cells(r, "F") = "" Then
'                           Put date stamp in column F
                            Cells(r, "F").Value = Date
                        End If
'               If column H (8th column) or I (9th column) updated
                Case 8, 9
'                   Check to see if both columns H and I are populated and J is empty
                    If (Cells(r, "H") <> "") And (Cells(r, "I") <> "") And (Cells(r, "J") = "") Then
                        Cells(r, "J").Value = Date
                    End If
            End Select
        End If
    Next cell
   
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

What you said about Worksheet_Change is correct, you cannot have multiple procedures in the same workbook with the same name.
And Event Procedures MUST be named a certain way, you cannot change their name.

So what you have to do is to combine the two codes into one large procedure, or create sub procedures that this one calls. Let me see if I can do something like that with this one.

 

[Joe4]

OK, try this. Leave your original Worksheet_Change procedure that you had previously. We are going to rename the one that I created like this:

Private Sub MyDateStamp(ByVal Target As Range)

    Dim rng As Range
    Dim cell As Range
    Dim r As Long
    Dim c As Long
 
    Application.ScreenUpdating = False
    Application.EnableEvents = False
 
'   Set range to encompass all columns we need to watch
    Set rng = Intersect(Target, Columns("D:I"))
 
'   Exit if no cells round
    If rng Is Nothing Then Exit Sub

'   Loop through all cells updated in watched range
    For Each cell In rng
'       Get row and column of update
        r = cell.Row
        c = cell.Column
'       Exclude row 1
        If r > 1 Then
'           See which column was just updated
            Select Case c
'               If column D (4th column)
                Case 4
'                   Check to see if column F is empty
                        If Cells(r, "F") = "" Then
'                           Put date stamp in column F
                            Cells(r, "F").Value = Date
                        End If
'               If column H (8th column) or I (9th column) updated
                Case 8, 9
'                   Check to see if both columns H and I are populated and J is empty
                    If (Cells(r, "H") <> "") And (Cells(r, "I") <> "") And (Cells(r, "J") = "") Then
                        Cells(r, "J").Value = Date
                    End If
            End Select
        End If
    Next cell
 
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

Place it right below your other code. Notice the only thing I changed is the name.
Then, add the line in red below to your current code, right after your variable declarations:

Private Sub Worksheet_Change(ByVal Destination As Range)
Dim rngDropdown As Range
Dim oldValue As String
Dim newValue As String
Dim DelimiterType As String
DelimiterType = ", "
Dim DelimiterCount As Integer
Dim TargetType As Integer
Dim i As Integer
Dim arr() As String

Call MyDateStamp(Destination)
 
If Destination.Count > 1 Then Exit Sub
On Error Resume Next

...

I believe this should now successfully run both codes.

 

[BigShanny]

I just finished adding Cases 11 & 12 and 14 & 15. This works beautifully! I really appreciate your help with this. I got way more than I expected as a reluctant first-time poster on this board. I'll be sure to use it again next time I get stuck. Joe, you've given me 3 years of my life back. I was so stressed about coming up with a solution for this nagging problem.

Thanks a million!

 

[Joe4]

You are welcome.
Glad I was able to help!