Copying sheets while preserving digital signatures

Question

-- Edit: this is now part of the bigger question of how to reliably move sheets about in this question\'s context --

(Note: during preparing this post and testing so

Answer 1

It's a lot to take in, and I do not pretnd this will answer will solve all your problems. But I once wrote a function called SoftLink which would take up to 4 parameters (i) Boolean: CellRef (or NamedRange) (ii) String: Range (iii) String: WorksheetName (iv) String: WorkbookName which would break any link with any cells and then you resolve the string parameters in VBA code.

There no doubt a performance hit with this approach but it is one way to solve Link hell.

Example calling formulas

=softlink(FALSE,"Foo")
=softlink(TRUE,"C4","Sheet1","Book2")
=softlink(TRUE,"D5","Sheet2")

and I have knocked up from memory an implementation. I have a phobia of On Errors .... so forgive some strange loopings in the subroutines.

Option Explicit

Function SoftLink(ByVal bIsCell As Boolean, ByVal sRangeName As String, _
                    Optional sSheetName As String, Optional sBookName As String) As Variant

    Dim vRet As Variant
    If Len(sRangeName) = 0 Then vRet = "#Cannot resolve null range name!": GoTo SingleExit '* fast fail


    Dim rngCaller As Excel.Range
    Set rngCaller = Application.Caller

    Dim wsCaller As Excel.Worksheet
    Set wsCaller = rngCaller.Parent

    Dim wbCaller As Excel.Workbook
    Set wbCaller = wsCaller.Parent

    Dim wb As Excel.Workbook

    If Len(sBookName) > 0 Then
        vRet = FindWorkbookWithoutOnErrorResumeNext(sBookName, wb)
        If Len(vRet) > 0 Then GoTo ErrorMessageExit
    Else
        Set wb = wbCaller
    End If
    Debug.Assert Not wb Is Nothing
    Dim ws As Excel.Worksheet
    If Len(sSheetName) > 0 Then
        vRet = FindWorksheetWithoutOnErrorResumeNext(wb, sSheetName, ws)
        If Len(vRet) > 0 Then GoTo ErrorMessageExit

    Else
        Set ws = wsCaller
    End If

    Dim rng As Excel.Range
    If bIsCell Then
        vRet = AcquireCellRange(ws, sRangeName, rng)
        If Len(vRet) > 0 Then GoTo ErrorMessageExit
    Else
        vRet = AcquireNamedRangeWithoutOERN(ws, sRangeName, rng)
        If Len(vRet) > 0 Then GoTo ErrorMessageExit
    End If

    SoftLink = rng.Value2
SingleExit:
    Exit Function
ErrorMessageExit:
    SoftLink = vRet
    GoTo SingleExit
End Function

Function AcquireCellRange(ByVal ws As Excel.Worksheet, ByVal sRangeName As String, ByRef prng As Excel.Range) As String

    On Error GoTo FailedCellRef
    Set prng = ws.Range(sRangeName)

SingleExit:
    Exit Function
FailedCellRef:
    AcquireCellRange = "#Could not resolve range name '" & sRangeName & "' on worksheet name '" & ws.Name & "' in workbook '" & ws.Parent.Name & "'!"

End Function


Function AcquireNamedRangeWithoutOERN(ByVal ws As Excel.Worksheet, ByVal sRangeName As String, ByRef prng As Excel.Range) As String

    '* because I do not like OERN
    Dim oNames As Excel.Names

    Dim bSheetScope As Long
    For bSheetScope = True To False

        Set oNames = VBA.IIf(bSheetScope, ws.Names, ws.Parent.Names)

        Dim namLoop As Excel.Name
        For Each namLoop In oNames
            If VBA.StrComp(namLoop.Name, sRangeName, vbTextCompare) = 0 Then

                Set prng = ws.Range(sRangeName)
                GoTo SingleExit
            End If

        Next
    Next

ErrorMessageExit:
    AcquireNamedRangeWithoutOERN = "#Could not resolve range name '" & sRangeName & "' on worksheet name '" & ws.Name & "' in workbook '" & ws.Parent.Name & "'!"
SingleExit:
    Exit Function

End Function

Function FindWorksheetWithoutOnErrorResumeNext(ByVal wb As Excel.Workbook, ByVal sSheetName As String, ByRef pws As Excel.Worksheet) As String
    '* because I do not like OERN
    Dim wsLoop As Excel.Worksheet
    For Each wsLoop In wb.Worksheets
        If VBA.StrComp(wsLoop.Name, sSheetName, vbTextCompare) = 0 Then
            Set pws = wsLoop

            GoTo SingleExit
        End If

    Next wsLoop
ErrorMessageExit:
    FindWorksheetWithoutOnErrorResumeNext = "#Could not resolve worksheet name '" & sSheetName & "' in workbook '" & wb.Name & "'!"
SingleExit:
    Exit Function
End Function


Function FindWorkbookWithoutOnErrorResumeNext(ByVal sBookName As String, ByRef pwb As Excel.Workbook) As String
    '* because I do not like OERN
    Dim wbLoop As Excel.Workbook
    For Each wbLoop In Application.Workbooks
        If VBA.StrComp(wbLoop.Name, sBookName, vbTextCompare) = 0 Then
            Set pwb = wbLoop

            GoTo SingleExit
        End If

    Next wbLoop
ErrorMessageExit:
    FindWorkbookWithoutOnErrorResumeNext = "#Could not resolve workbook name '" & sBookName & "'!"
SingleExit:
    Exit Function
End Function