Copy Formula from Cell 200 of that column into deleted Cell - VB

E

eli_m

Board Regular
Joined
Jun 2, 2022
Messages
129
Office Version
  1. 365
Platform
  1. Windows
Hi - This site has helped me so much I thought I'd sign up and ask my own question and hopefully help others :)

My question:
What would be the VB code for when I delete data from a cell it then automatically copies the formula that's in cell 200 of that row into the newly deleted cell?

eg.

1. Delete data in cell A1
2. Formula from A200 gets put into cell A1

I also want it to work for all my columns which is A to AR.

Another example:

1. Delete data from F68
2. Formula from F200 populates into F68

Any help would be greatly appreciated!

Thank you in advance
 
Sort by date Sort by votes
Peter_SSs said:
Pure guess as I still don't know what worksheets are in your workbook, what sheet the 'ignore errors' code is supposed to act on if there is more than one worksheet in the workbook or what the On Error Resume Next is supposed to be protecting against.

As written, this code will do the ignore errors on whatever the active sheet is when the workbook is opened. If there are multiple sheets and the ignore errors needs to act on a particular sheet then that will need to be built into the code, most likely based on the name of that worksheet.
Click to expand...

Thanks for your help - I no longer get error messages and the ignore errors work but the sorting doesn't. Both parts of the code are just for the worksheet titled "IPS Cases".
This worked but I only want it to now sort when the workbook is opened and not for when the workbook is deactivated:

VBA Code: 
' Sort by Surgery Date with Worksheet Activation after Deactivation
Private Sub Worksheet_Deactivate()
  ThisWorkbook.RefreshAll

On Error Resume Next

If Not Intersect(Target, ThisWorkbook.Sheets("IPS Cases").Range("B:B")) Is Nothing Then
ThisWorkbook.Sheets("IPS Cases").Range("B2").Sort Key1:=ThisWorkbook.Sheets("IPS Cases").Range("B3"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

End If

End Sub

Is there a way to put that into Private Sub Workbook_Open() ?
 
Upvote 0

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
I got this to fix the sorting but now the errors that should be ignored show(possibly due to it sorting after the ignore error)?

Code: 
Private Sub Workbook_Open()
  Dim r As Range
  Dim cel As Range
 
  Set r = Range("A2:AR200")
  For Each cel In r
    With cel
      .Errors(8).Ignore = True 'Data Validation Error
      .Errors(9).Ignore = True 'Inconsistent Error
      .Errors(6).Ignore = True 'Lock Error
    End With
  Next cel

  ThisWorkbook.RefreshAll

  On Error Resume Next

If Not Intersect(Target, ThisWorkbook.Sheets("IPS Cases").Range("B:B")) Is Nothing Then
ThisWorkbook.Sheets("IPS Cases").Range("B2").Sort Key1:=ThisWorkbook.Sheets("IPS Cases").Range("B3"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

End If

End Sub


I tried swapping it around and get a "Object required error":

Code: 
Private Sub Workbook_Open()

If Not Intersect(Target, ThisWorkbook.Sheets("IPS Cases").Range("B:B")) Is Nothing Then
ThisWorkbook.Sheets("IPS Cases").Range("B2").Sort Key1:=ThisWorkbook.Sheets("IPS Cases").Range("B3"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

End If


  Dim r As Range
  Dim cel As Range
 
  Set r = Range("A2:AR200")
  For Each cel In r
    With cel
      .Errors(8).Ignore = True 'Data Validation Error
      .Errors(9).Ignore = True 'Inconsistent Error
      .Errors(6).Ignore = True 'Lock Error
    End With
  Next cel

  ThisWorkbook.RefreshAll

  On Error Resume Next


End Sub
 
Last edited:
Upvote 0
eli_m said:
Both parts of the code are just for the worksheet titled "IPS Cases".
Click to expand...
Thanks for that additional information.
Try this Workbook_Open code and get rid of the Deactivate code.

VBA Code: 
Private Sub Workbook_Open()
  Dim cel As Range
  
  Application.ScreenUpdating = False
  ThisWorkbook.RefreshAll
  With Sheets("IPS Cases")
    On Error Resume Next
    Intersect(.Columns("B"), .UsedRange).Sort Key1:=.Range("B3"), Order1:=xlAscending, Header:=xlYes
    On Error GoTo 0
    For Each cel In .Range("A2:AR200")
      With cel
        .Errors(8).Ignore = True
        .Errors(9).Ignore = True
        .Errors(6).Ignore = True
      End With
    Next cel
  End With
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
Peter_SSs said:
Thanks for that additional information.
Try this Workbook_Open code and get rid of the Deactivate code.

VBA Code: 
Private Sub Workbook_Open()
  Dim cel As Range
 
  Application.ScreenUpdating = False
  ThisWorkbook.RefreshAll
  With Sheets("IPS Cases")
    On Error Resume Next
    Intersect(.Columns("B"), .UsedRange).Sort Key1:=.Range("B3"), Order1:=xlAscending, Header:=xlYes
    On Error GoTo 0
    For Each cel In .Range("A2:AR200")
      With cel
        .Errors(8).Ignore = True
        .Errors(9).Ignore = True
        .Errors(6).Ignore = True
      End With
    Next cel
  End With
  Application.ScreenUpdating = True
End Sub
Click to expand...
Thank you once again :) that didn't work but I added some more code from the original and got this to work:

VBA Code: 
Private Sub Workbook_Open()
  Dim cel As Range
 
  Application.ScreenUpdating = False
  ThisWorkbook.RefreshAll
  With Sheets("IPS Cases")
    On Error Resume Next
    ThisWorkbook.Sheets("IPS Cases").Range("B2").Sort Key1:=ThisWorkbook.Sheets("IPS Cases").Range("B3"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
    On Error GoTo 0
    For Each cel In .Range("A2:AR200")
      With cel
        .Errors(8).Ignore = True
        .Errors(9).Ignore = True
        .Errors(6).Ignore = True
      End With
    Next cel
  End With
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
Peter_SSs said:
Can you detail in what way it didn't work?
Click to expand...
It just wasn't automatically sorting Column B when the workbook was opened with your code:
VBA Code: 
Private Sub Workbook_Open()
  Dim cel As Range
 
  Application.ScreenUpdating = False
  ThisWorkbook.RefreshAll
  With Sheets("IPS Cases")
    On Error Resume Next
    Intersect(.Columns("B"), .UsedRange).Sort Key1:=.Range("B3"), Order1:=xlAscending, Header:=xlYes
    On Error GoTo 0
    For Each cel In .Range("A2:AR200")
      With cel
        .Errors(8).Ignore = True
        .Errors(9).Ignore = True
        .Errors(6).Ignore = True
      End With
    Next cel
  End With
  Application.ScreenUpdating = True
End Sub


I used a bit of your code and a bit of my old code and got it to work. So now when I open up the workbook it sorts column b:


VBA Code: 
Private Sub Workbook_Open()
  Dim cel As Range
 
  Application.ScreenUpdating = False
  ThisWorkbook.RefreshAll
  With Sheets("IPS Cases")
    On Error Resume Next
    ThisWorkbook.Sheets("IPS Cases").Range("B2").Sort Key1:=ThisWorkbook.Sheets("IPS Cases").Range("B3"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
    On Error GoTo 0
    For Each cel In .Range("A2:AR200")
      With cel
        .Errors(8).Ignore = True
        .Errors(9).Ignore = True
        .Errors(6).Ignore = True
      End With
    Next cel
  End With
  Application.ScreenUpdating = True
End Sub


The thing I changed was:


VBA Code: 
Intersect(.Columns("B"), .UsedRange).Sort Key1:=.Range("B3"), Order1:=xlAscending, Header:=xlYes

to

VBA Code: 
ThisWorkbook.Sheets("IPS Cases").Range("B2").Sort Key1:=ThisWorkbook.Sheets("IPS Cases").Range("B3"), _

Order1:=xlAscending, Header:=xlYes, _

OrderCustom:=1, MatchCase:=False, _

Orientation:=xlTopToBottom
 
Upvote 0
eli_m said:
It just wasn't automatically sorting Column B when the workbook was opened
Click to expand...
Hmm, it did for me. Perhaps I had something set up a bit differently in my 'IPS Cases' worksheet. Anyway, the main thing is you have it working now. (y)
 
Upvote 0
Hi there,

Me again!

This code has been working amazingly:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

' Copy from Line 200 into deleted cells
  Dim Changed As Range, c As Range
 
  Set Changed = Intersect(Target, Columns("A:AR"))
  If Not Changed Is Nothing Then
    Application.EnableEvents = False
    For Each c In Changed
      If IsEmpty(c.Value) Then Cells(200, c.Column).Copy Destination:=c
    Next c
    Application.EnableEvents = True
  End If

' Ignore Errors with Worksheet Clicks
Dim r As Range: Set r = Range("A2:AR200")
Dim cel As Range

For Each cel In r
  With cel
    .Errors(8).Ignore = True 'Data Validation Error
    .Errors(9).Ignore = True 'Inconsistent Error
    .Errors(6).Ignore = True 'Lock Error
  End With
Next cel

End Sub

but my problem is with:
VBA Code: 
  Set Changed = Intersect(Target, Columns("A:AR"))
  If Not Changed Is Nothing Then
    Application.EnableEvents = False
    For Each c In Changed
      If IsEmpty(c.Value) Then Cells(200, c.Column).Copy Destination:=c
    Next c
    Application.EnableEvents = True
  End If

When I delete a column it scans EVERY row of my worksheet well passed 200.

I tried
Set Changed = Intersect(Target, Columns("A3:AR200"))
with no luck.

It might be another code causing this issue so my whole code for the sheet is:
VBA Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.CutCopyMode = False Then
Application.Calculate
End If
End Sub

' Ignore Errors when Worksheet Activated
Private Sub Worksheet_Activate()

Dim r As Range: Set r = Range("A2:AR200")
Dim cel As Range

For Each cel In r
  With cel
    .Errors(8).Ignore = True 'Data Validation Error
    .Errors(9).Ignore = True 'Inconsistent Error
    .Errors(6).Ignore = True 'Lock Error
  End With
Next cel

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

' Copy from Line 200 into deleted cells
  Dim Changed As Range, c As Range
 
  Set Changed = Intersect(Target, Columns("A:AR"))
  If Not Changed Is Nothing Then
    Application.EnableEvents = False
    For Each c In Changed
      If IsEmpty(c.Value) Then Cells(200, c.Column).Copy Destination:=c
    Next c
    Application.EnableEvents = True
  End If

' Ignore Errors with Worksheet Clicks
Dim r As Range: Set r = Range("A2:AR200")
Dim cel As Range

For Each cel In r
  With cel
    .Errors(8).Ignore = True 'Data Validation Error
    .Errors(9).Ignore = True 'Inconsistent Error
    .Errors(6).Ignore = True 'Lock Error
  End With
Next cel

End Sub
' Auto Refresh Pivot Tables
Private Sub Worksheet_Deactivate()
  ThisWorkbook.RefreshAll

On Error Resume Next

End Sub



Thanks!
 
Upvote 0
Untested with your actual code, but if you put this right at the start of the Worksheet_Change code it should exit the code if whole columns are deleted/inserted/changed

VBA Code: 
If Target.CountLarge / Rows.Count = Int(Target.CountLarge / Rows.Count) Then Exit Sub
 
Upvote 0
Peter_SSs said:
Untested with your actual code, but if you put this right at the start of the Worksheet_Change code it should exit the code if whole columns are deleted/inserted/changed

VBA Code: 
If Target.CountLarge / Rows.Count = Int(Target.CountLarge / Rows.Count) Then Exit Sub
Click to expand...
Amazing! works a treat :)
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question
Delete Cell Range, or Add Range and Copy Formulas etc. - Excel VBA
Replies
0
Views
93
CSTjr
C
B
  • Solved
VBA to delete certain sheets based on cell contents with IF formula
Replies
3
Views
203
Peter_SSs
Peter_SSs
Z
  • Question
how to delete columns in a pattern.
Replies
5
Views
207
Zeema
Z
S
  • Solved
Copy/Paste cell if checkbox selected
Replies
4
Views
363
kevin9999
K
N
  • Question
trying to use only 1 formula to populate the information in various columns which are not adjacent to each other.
Replies
3
Views
105
noaman79
N

Forum statistics

Threads
1,215,417
Messages
6,124,777
Members
449,187
Latest member
hermansoa

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top