Is there any way that 'filling' can be restricted to values only and not formatting, perhaps through VBA?

[Rnkhch]

Hello,

I know that it is possible to right-click and drag and then select 'fill without formatting', but is there any formatting changes can be disabled for dragging/filling, perhaps through a VBA code?

Thanks for any input!

 

[johnnyL]

Looks like everyone else dropped out of the race. Oh Well Try the following to handle the remaining issue you mentioned:

Private Sub Worksheet_Change(ByVal Target As Range)
'
    Dim EndDragColumnNumber     As Long, StartDragColumnNumber      As Long
    Dim EndDragRowString        As String
    Dim EndDragColumnLetter     As String
    Dim TargetAddressArray      As Variant
'
    TargetAddressArray = Split(Target.Address(0, 0), ":")
'
    EndDragColumnLetter = Evaluate(Replace("=LEFT(""X"",MIN(FIND({0,1,2,3,4,5,6,7,8,9}" & _
            ",ASC(""X"")&1234567890))-1)", "X", TargetAddressArray(1)))                         ' Get EndDragColumnLetter of TargetAddressArray(1)
    EndDragColumnNumber = Range(EndDragColumnLetter & 1).Column                                 ' Get Column Number of EndDragColumnLetter
    StartDragColumnNumber = Range(Evaluate(Replace("=LEFT(""X"",MIN(FIND({0,1,2,3,4,5,6,7,8,9}" & _
            ",ASC(""X"")&1234567890))-1)", "X", TargetAddressArray(0))) & 1).Column             ' Get StartDragColumnNumber of TargetAddressArray(0)
'
    EndDragRowString = Right(TargetAddressArray(1), Len(TargetAddressArray(1)) - _
            Len(EndDragColumnLetter))                                                           ' Get EndDragRow
'
    If Application.WorksheetFunction.CountA(Target) = 0 Then Exit Sub                           ' Check/Allow deletetions
'
    If Not Intersect(Target, Range("E3:E42")) Is Nothing And Target.CountLarge > 1 Or _
            Not Intersect(Target, Range("F3:F42")) Is Nothing And Target.CountLarge > 1 Or _
            Not Intersect(Target, Range("G3:G42")) Is Nothing And Target.CountLarge > 1 Then
        With Application
            .EnableEvents = False
            .Undo
            Range(Cells(Target.Row - 1, StartDragColumnNumber), Cells(Target.Row - 1, _
                    EndDragColumnNumber)).AutoFill Destination:=Range(Cells(Target.Row - 1, _
                    StartDragColumnNumber), Cells(EndDragRowString, EndDragColumnNumber)), Type:=xlFillValues
            .EnableEvents = True
        End With
    End If
End Sub

 

[Rnkhch]

Thank you! I knew you would go till the end Almost there. The code was fabulous in all the aspects that we discussed, except a bug:

When I'm editing any cell in columns E,F, or G, I immediately get compiler error, which bounces to the following highlighted lines in the editor:

EndDragColumnLetter = Evaluate(Replace("=LEFT(""X"",MIN(FIND({0,1,2,3,4,5,6,7,8,9}" & _
",ASC(""X"")&1234567890))-1)", "X", TargetAddressArray(1))) '

So basically, if there is already text in the cells, then the dragging and everything works perfectly well, but if I add anything, it gives error. We should be all set after this bug fix

 

[johnnyL]

Ok, How about:

Private Sub Worksheet_Change(ByVal Target As Range)
'
    Dim EndDragColumnNumber     As Long, StartDragColumnNumber      As Long
    Dim EndDragRowString        As String
    Dim EndDragColumnLetter     As String
    Dim TargetAddressArray      As Variant
'
    If Target.CountLarge < 2 Then Exit Sub
'
    TargetAddressArray = Split(Target.Address(0, 0), ":")
'
    EndDragColumnLetter = Evaluate(Replace("=LEFT(""X"",MIN(FIND({0,1,2,3,4,5,6,7,8,9}" & _
            ",ASC(""X"")&1234567890))-1)", "X", TargetAddressArray(1)))                         ' Get EndDragColumnLetter of TargetAddressArray(1)
    EndDragColumnNumber = Range(EndDragColumnLetter & 1).Column                                 ' Get Column Number of EndDragColumnLetter
    StartDragColumnNumber = Range(Evaluate(Replace("=LEFT(""X"",MIN(FIND({0,1,2,3,4,5,6,7,8,9}" & _
            ",ASC(""X"")&1234567890))-1)", "X", TargetAddressArray(0))) & 1).Column             ' Get StartDragColumnNumber of TargetAddressArray(0)
'
    EndDragRowString = Right(TargetAddressArray(1), Len(TargetAddressArray(1)) - _
            Len(EndDragColumnLetter))                                                           ' Get EndDragRow
'
    If Application.WorksheetFunction.CountA(Target) = 0 Then Exit Sub                           ' Check/Allow deletetions
'
    If Not Intersect(Target, Range("E3:E42")) Is Nothing And Target.CountLarge > 1 Or _
            Not Intersect(Target, Range("F3:F42")) Is Nothing And Target.CountLarge > 1 Or _
            Not Intersect(Target, Range("G3:G42")) Is Nothing And Target.CountLarge > 1 Then
        With Application
            .EnableEvents = False
            .Undo
            Range(Cells(Target.Row - 1, StartDragColumnNumber), Cells(Target.Row - 1, _
                    EndDragColumnNumber)).AutoFill Destination:=Range(Cells(Target.Row - 1, _
                    StartDragColumnNumber), Cells(EndDragRowString, EndDragColumnNumber)), Type:=xlFillValues
            .EnableEvents = True
        End With
    End If
End Sub

 

[Rnkhch]

OMG, it works so well now!!! You did it! Thanks much! I'll mark it as solution

 

[johnnyL]

Glad we could help.

 

[Rnkhch]

Thanks! This is a revolutionary thread actually. When I was searching the web, there were numerous posts looking for exactly what you did here, but none of the solutions were even remotely satisfactory, and majority were defunct. Everybody's gonna love your work!

 

[johnnyL]

It's a team effort. We all get ideas from what others have previously mentioned.

 

[Rnkhch]

Good morning

Just made a couple of minor observations which I thought to share with you. Technically not important, so if you're too busy, you don't have to spend time on them, but if you wanna make the code even more perfect :

1. I noticed that if an empty cell is dragged, then formatting carries over
2. Dragging up doesn't work

Otherwise, I already gave the updated sheets to my students, and they said it's working very well

 

[johnnyL]

I swear, you are worse than flies at a picnic.

I think I previously stated that the code would get 'YOU' started, not 'ME'.

Just kidding.

Try the following:

Private Sub Worksheet_Change(ByVal Target As Range)
'
    Dim SelectionRow            As Long
    Dim EndDragColumnLetter     As String, StartDragColumnLetter    As String
    Dim TargetAddressArray      As Variant
'
    If Target.CountLarge < 2 Then Exit Sub                                                      ' If only 1 cell has been selected by user, allow the change
    If Application.WorksheetFunction.CountA(Target) = 0 Then Exit Sub                           ' Check/Allow deletetions via the delete key
'
    SelectionRow = Selection.Row                                                                ' Save the Selection.Row into SelectionRow
'
    TargetAddressArray = Split(Selection.Address(0, 0), ":")                                    ' Separate Address Range into TargetAddressArray
'
    EndDragColumnLetter = Evaluate(Replace("=LEFT(""X"",MIN(FIND({0,1,2,3,4,5,6,7,8,9}" & _
            ",ASC(""X"")&1234567890))-1)", "X", TargetAddressArray(1)))                         ' Get EndDragColumnLetter of TargetAddressArray(1)
'
    StartDragColumnLetter = Evaluate(Replace("=LEFT(""X"",MIN(FIND({0,1,2,3,4,5,6,7,8,9}" & _
            ",ASC(""X"")&1234567890))-1)", "X", TargetAddressArray(0)))                         ' Get StartDragColumnLetter of TargetAddressArray(0)
'
    If Not Intersect(Target, Range("E3:E42")) Is Nothing And Target.CountLarge > 1 Or _
            Not Intersect(Target, Range("F3:F42")) Is Nothing And Target.CountLarge > 1 Or _
            Not Intersect(Target, Range("G3:G42")) Is Nothing And Target.CountLarge > 1 Then    '   If change was made to ranges we are monitoring then ...
'
        With Application
            .EnableEvents = False                                                               '       Turn Events off to prevent potential code loop
            .Undo                                                                               '       Undo the change that was made by the user
'
            If SelectionRow = ActiveCell.Row Then                                               '       If Dragging down then ...
                Range(TargetAddressArray(0) & ":" & EndDragColumnLetter & _
                        ActiveCell.Row).AutoFill Destination:=Range(TargetAddressArray(0) & _
                        ":" & TargetAddressArray(1)), Type:=xlFillValues                        '           Make the user changes without affecting format
            Else                                                                                '       Else ...
                Range(StartDragColumnLetter & ActiveCell.Row & ":" & EndDragColumnLetter & _
                        ActiveCell.Row).AutoFill Destination:=Range(TargetAddressArray(1) & _
                        ":" & TargetAddressArray(0)), Type:=xlFillValues                        '           Make the user changes without affecting format
            End If
'
            .EnableEvents = True                                                                '       Turn Events back on
        End With
    End If
End Sub

The dragging up issue should be resolved.
The blank cell dragging, not so much. In order to allow for deletions, you have to allow blank cells to be processed normally. Perhaps somebody else has an idea how to handle that scenario.

 

[Rnkhch]

Wow, this is spectacular! I dragged one cell up and another one down in a different column, and both worked very well. You're absolute number one! I'll see if I can change which post is marked as solution, and if I can, I'll set your post #49 as solution.

It's fine even if the blank cell dragging is not solved. The code is super amazing already

P.S. Just saw the beginning of your post lol I should tag you in all my VBA posts in future lol