Forcing Match Destination Formatting

[Lilii]

Hi all,

I'm very new to Excel VBA so please bear with me.

I'm currently trying to force users to paste only so that it matches the destination formatting.

I've seen the following posts but it doesn't work for my situation:

• Allow user to only paste values, not formats
• Best way to force a Paste Values only
• Force Paste Special Values
• VBA - Restrict Users To Paste As Values Only

The cells where you can copy are the only Unlocked cells of my spreadsheet, knowing that the sheet would ideally be protected once my work is done.

I've also tried to see how excel is actually coding the paste matching destination formatting using the record macro button, and it gave me this:

    ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:= _
        False, NoHTMLFormatting:=True

Can someone please help me find a work around, I've been at it for hours and still can't get it to work.

Thanks a lot for your help!

Lili

 

[James006]

Hi,

It seems to me you are locking yourself up in a preconceived solution ...

Would you mind explaining the general overview, and the situation you are facing ... before summarizing the obstacle or complication you do need to overcome

 

[Lilii]

Of course, sorry for that!

I'm creating a control panel for my team that allows them to access various links that they need on their day to day. I plan on leaving the team soon and I want this document to still be used when I'm gone. In order to do so, I created a settings tab on top of the main tab, so that they can amend the link of the various buttons that are on the main page.

I found a way to "paste values" by unlocking the sheet and enter everything that describes how the cell should look like, then locking the sheet up again:

'Paste Values Only
Private Sub Worksheet_Change(ByVal Target As Range)
'Intro Data
Dim rChanged As Range

'If cells in D are changed
Set rChanged = Intersect(Target, Me.Range("D1:D11"))
If rChanged Is Nothing Then Exit Sub
 
'Get the last operation from the undo stack
If Worksheets("Settings").ProtectContents = True Then
If Application.CommandBars("Standard").FindControl(ID:=128).List(1) = "Paste" Then

'Redo Format
Worksheets("Settings").Unprotect "password"
Range("D1:D11").VerticalAlignment = xlCenter
Range("D1:D11").HorizontalAlignment = xlLeft
Range("D1:D11").WrapText = True
Range("D1:D11").Borders.LineStyle = Excel.XlLineStyle.xlLineStyleNone
Range("D1:D1").Borders(xlEdgeTop).Color = RGB(255, 255, 255)
Range("D1:D11").Borders(xlEdgeRight).Color = RGB(255, 255, 255)
Range("D1:D11").Font.Color = RGB(255, 255, 255)
Range("D1:D11").Font.Name = Arial
Range("D1:D11").Font.Size = 11
Range("D1:D11").Font.Bold = False
Range("D1:D11").Font.Italic = False
Range("D1:D11").Font.Underline = False
Range("D1:D11").Interior.Color = RGB(0, 118, 129)
Worksheets("Settings").Protect "password"

End If

End If

Application.EnableEvents = False

End Sub

Now I have another problem. When an URL is changed, I coded it so that it is copied from D (only cells that are unlocked, where the user pastes the URL they want to amend) and pasted to B (URL used in the code to use the buttons in the main page). When it pastes (I used paste special in my code), it tells me "Run-time error '1004': PasteSpecial method of Range class failed", and when I click "Debug, it highlights "Range("B7").PasteSpecial (xlPasteValues)". Here's the sub I have for one of the buttons for better understanding:

    'Change Change Tracker URL
    Sub settings_change()
     '1 - Introduction
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Application.CutCopyMode = False
        
        Dim answer As Integer
        Dim url_name As String
        Dim current_url As String
        Dim new_url As String
        Dim new_url_trim As String
        
        url_name = Range("A7")
        current_url = Range("B7")
        new_url = Range("D7")
    
    
        '2 - Button Click Action
        answer = MsgBox("You are changing " & url_name & " from:" & vbCrLf & vbCrLf & current_url & vbCrLf & vbCrLf & "To:" & vbCrLf & vbCrLf & new_url & vbCrLf & vbCrLf & "Is that okay?", vbYesNo + vbDefaultButton2, Range("A7") & " Update")
        
        If answer = vbYes Then
            
        '3 - Validation
        new_url_trim = Trim(new_url)
        
            'New URL has more than 12 char
            If Len(new_url_trim) < 12 Then
            GoTo msgbox_error
            End If
            
            'New URL has less than 1000 char
            If Len(new_url_trim) > 1000 Then
            GoTo msgbox_error
            End If
            
            'New URL starts with "https://"
            If InStr(1, new_url_trim, "https://", 1) = 0 Then
            GoTo msgbox_error
            End If
            
            'New URL ends in ".xls*"
            If InStr(Len(new_url_trim) - 5, new_url_trim, ".xls", 1) = 0 Then
            
            'Error Output
msgbox_error:
            MsgBox "The URL your are trying to update doesn't appear to be correct. Please check the following and try again:" & vbCrLf & vbCrLf & "- Link URL between 12 and 1,000 characters" & vbCrLf & "- Link URL starts with https://" & vbCrLf & "- Link URL ends with an Excel extention (.xls, .xlsm, .xlsx, ...)", vbOKOnly, "URL Error"
            
            Else
            
            Range("D7").Copy
            
            Worksheets("Settings").Unprotect "password"
            
            Range("B7").PasteSpecial (xlPasteValues)
            
            Range("D7").Font.Color = RGB(200, 220, 86)
            
            Range("D7").Value = "URL changed successfully"
            
            Worksheets("Settings").Protect "password"
        
            End If
        
        Else
        
        '4 - Conclusion
        End If

        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Application.CutCopyMode = False
        
    End Sub

I've also input some data validation in there, please ignore it.

Thank you in advance for any help you can provide me with!

 

[Lilii]

Also, the first code is in the worksheet "settings", the second in a module.

 

[James006]

Hi,

Thanks a lot for your explanations ....

You could test following set of instructions after passing all your checks ...

' New Set of Instructions
     Worksheets("Settings").Unprotect "password"
     Range("B7").Value = Range("D7").Value
     Range("D7").Font.Color = RGB(200, 220, 86)
     Range("D7").Value = "URL changed successfully"
     Worksheets("Settings").Protect "password"

 

[Lilii]

I'm so sorry for the long answer!

I've tried but the code always bugs once run more than once, since the pasting option becomes greyed out and can't be used. I have to manually reset it for it to run once, but then it freezes again if I use the code more than once. Any idea how to get around that? Thank you again!

 

[James006]

Would you mind posting your entire macro ... in order to determine what might be the problem ...

 

[Lilii]

Of course! Here is the macro I'm using. It allows me to check if what the user entered in D11 follows the correct format (starts with https:// for example), then unlocks the spreadsheet, copy what the user entered, unlocks the spreadsheet, paste specials and relocks the spreadsheet. This is a module. There is nothing the the Sheet itself, or the workbook:
'Change Confluence URL

    Sub settings_confluence()
     '1 - Introduction
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Application.CutCopyMode = False
        
        Dim answer As Integer
        Dim url_name As String
        Dim current_url As String
        Dim new_url As String
        Dim new_url_trim As String
        
        url_name = Range("A11")
        current_url = Range("B11")
        new_url = Range("D11")
    
    
        '2 - Button Click Action (1)
        answer = MsgBox("You are changing " & url_name & " from:" & vbCrLf & vbCrLf & current_url & vbCrLf & vbCrLf & "To:" & vbCrLf & vbCrLf & new_url & vbCrLf & vbCrLf & "Is that okay?", vbYesNo + vbDefaultButton2, Range("A11") & " Update")
        
        If answer = vbYes Then
            
         '3 - Validation
        new_url_trim = Trim(new_url)
        
            'New URL has more than   12 char
            If Len(new_url_trim) < 12 Then
            GoTo msgbox_error
            End If
            
            'New URL has less than 1000 char
            If Len(new_url_trim) > 1000 Then
            GoTo msgbox_error
            End If
            
            'New URL starts with "https://"
            If InStr(1, new_url_trim, "https://", 1) = 0 Then
            
            'Error Output
msgbox_error:
            MsgBox "The URL your are trying to update doesn't appear to be correct. Please check the following and try again:" & vbCrLf & vbCrLf & "- Link URL between 12 and 1,000 characters" & vbCrLf & "- Link URL starts with https://" & vbCrLf & "- Link URL ends with an Excel extention", vbOKOnly, "URL Error"
            
            Else
            
            Range("D11").Copy
                
            Worksheets("Settings").Unprotect "password"
            
            Range("B11").PasteSpecial
            Range("D11").Font.Color = RGB(159, 169, 35)
            Range("D11").Font.Name = Arial
            Range("D11").Font.Size = 11
            Range("D11").Font.Bold = True
            Range("D11").Font.Italic = False
            Range("D11").Font.Underline = False
            
            Range("D11").Value = "URL changed successfully"
            
            Worksheets("Settings").Protect "password"
        
            End If
        
        Else
        
        '4 - Conclusion
        End If

        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Application.CutCopyMode = False
        
    End Sub

Now, each and everytime I run the code, it bugs at "Paste Special", and the paste option when I right click is greyed out. I have to use the Commandbars("Cell").Reset command in the immediate command prompt to unlock it. Any help you would be able to give me would be highly appreciated. Thank you!

 

[James006]

Hi,

Instead of the Copy - PasteSpecial instructions you are using ... you could test

Worksheets("Settings").Range("B11").Value = ActiveSheet.Range("D11").Value

 

[mumps]

This line of code:

Range("D11").Copy

is trying to copy D11 while the sheet is still protected. Move this line of code:

Worksheets("Settings").Unprotect "password"

directly above this line:

Range("D11").Copy

I would also suggest that you unlock D11 so that you can enter anew URL>