I have a macro that detects when a cell is changed, and adds this number to cell above it.
However I then need to clear the original cell, which always triggers the macro again as that cell is being changed again, and I end up an endless loop. Is there a way to "ignore" any other cell changes whilst the macro runs?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("B3:O3")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
If Range(Target.Address).Cells.Count = 1 Then
Range(Target.Address).Offset(-1).Value = Range(Target.Address).Offset(-1).Value + Range(Target.Address).Value
Range(Target.Address).Clear
End If
End If
End Sub
Or simply add Application.EnableEvents as follows:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("B3:O3")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
If Range(Target.Address).Cells.Count = 1 Then
Application.EnableEvents = False
Range(Target.Address).Offset(-1).Value = Range(Target.Address).Offset(-1).Value + Range(Target.Address).Value
Range(Target.Address).Clear
Application.EnableEvents = True
End If
End If
End Sub
You can add additional condition:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A3:O3")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing And Range(Target.Address).Value <> "" Then
If Range(Target.Address).Cells.Count = 1 Then
Range(Target.Address).Offset(-1).Value = Range(Target.Address).Offset(-1).Value + Range(Target.Address).Value
Range(Target.Address).Clear
End If
End If
End Sub
Related
Can someone please point out what's wrong with this snippet of code? Every time a value is changed in the specified range (A1:B6), Excel simply quits with Microsoft Error Reporting dialogue. I am not allowed to uncheck 'Error Checking (Turn on background error checking)' in Excel Preferences.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A1:B6")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
Call Macro1
MsgBox "Test"
End If
End Sub
Macro1:
Sub Macro1()
Dim wb As Workbook
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim rInterestCell As Range
Dim rDest As Range
Set wb = ActiveWorkbook
Set wsData = wb.Sheets("Sheet1")
Set wsDest = wb.Sheets("Formula Results")
For Each rInterestCell In Range("Interest_Range").Cells
wsData.Range("A7").Value = rInterestCell.Value
wsData.Calculate
Set rDest = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
If rDest.Row < 6 Then Set rDest = wsDest.Range("A6")
rDest.Value = wsData.Range("A6").Value
Next rInterestCell
End Sub
Second Macro
Sub Macro2()
Dim FLrange As Range
Set FLrange = Range(“Initial_Rate”)
For Each cell In FLrange
cell.Offset(0, 5).Formula = "=SUM(B3/100*A7)”
Next cell
End Sub
You'd better turn off events with Application.EnableEvents = False before doing so much calculation in Macro1.
If this works, just comment MsgBox "Before Macro1" and MsgBox "After Macro1"
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Me.Range("A1:B6")
If Not Application.Intersect(KeyCells, Target) Is Nothing Then
MsgBox "Before Macro1"
Macro1
MsgBox "After Macro1"
End If
End Sub
Macro1:
Sub Macro1()
Dim wB As Workbook
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim rInterestCell As Range
Dim rDest As Range
Set wB = ActiveWorkbook
Set wsData = wB.Sheets("Sheet1")
Set wsDest = wB.Sheets("Formula Results")
Application.EnableEvents = False
For Each rInterestCell In Range("Interest_Range").Cells
wsData.Range("A7").Value = rInterestCell.Value
wsData.Calculate
DoEvents
Set rDest = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
If rDest.Row < 6 Then Set rDest = wsDest.Range("A6")
rDest.Value = wsData.Range("A6").Value
Next rInterestCell
Application.EnableEvents = True
End Sub
I am running a VBA script to auto-capitalize and remove hyphens from pasted data into Excel. This script works great on single-line pastes (single-cell), but will not run (does nothing to change the data) if multiple lines of data are pasted in. The following is my code:
Private Sub worksheet_change(ByVal target As Range)
Application.EnableEvents = False
With target
On Error Resume Next
Dim rng As Range
Set rng = Range("A:U")
If Not Intersect(target, rng) Is Nothing Then
If Not .HasFormula Then
.Value = UCase(.Value)
.Value = Replace(.Value, "-", "")
End If
End If
End With
Application.EnableEvents = True
End Sub
Try this
Private Sub worksheet_change(ByVal target As Range)
Application.EnableEvents = False
With target
On Error Resume Next
Dim rng As Range
Dim cell As Range
Set rng = Range("A:U")
If Not Intersect(target, rng) Is Nothing Then
For Each cell in target
If Not cell.HasFormula Then
cell.Value = UCase(cell.Value)
cell.Value = Replace(cell.Value, "-", "")
End If
next cell
End If
End With
Application.EnableEvents = True
End Sub
I have the following sub in a worksheet, but I need another 3 of the same in the same worksheet for different cells/pivots. How can I do that?
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'This line stops the worksheet updating on every change, it only updates when cell
'B1 or B2 is touched
If Intersect(Target, Range("B1:B2")) Is Nothing Then Exit Sub
'Set the Variables to be used
Dim pt As PivotTable
Dim Field As PivotField
Dim NewCat As String
'Here you amend to suit your data
Set pt = Worksheets("Daily Overall").PivotTables("DailyOverallSignups")
Set Field = pt.PivotFields("Reg Year")
NewCat = Worksheets("Daily Overall").Range("B1").Value
'This updates and refreshes the PIVOT table
With pt
Field.ClearAllFilters
Field.CurrentPage = NewCat
pt.RefreshTable
End With
End Sub
I assume that by "the same" you mean that they all need to be in worksheet_selectionchange? Since your code currently exits if it isn't b1:b2, change your code to not exit at that point by adding other ranges. You should also have error handling and enableevents in there.
Private Sub Worksheet_SelectionChange(ByVal target As Range)
On Error GoTo Bummer
'This line stops the worksheet updating on every change, it only updates when cell
'B1 or B2 is touched
If Not Intersect(target, Range("B1:B2")) Is Nothing Then 'if not nothing
Application.EnableEvents = False
'Set the Variables to be used
Dim pt As PivotTable
Dim Field As PivotField
Dim NewCat As String
'Here you amend to suit your data
Set pt = Worksheets("Daily Overall").PivotTables("DailyOverallSignups")
Set Field = pt.PivotFields("Reg Year")
NewCat = Worksheets("Daily Overall").Range("B1").Value
'This updates and refreshes the PIVOT table
With pt
Field.ClearAllFilters
Field.CurrentPage = NewCat
pt.RefreshTable
End With
ElseIf Not Intersect(target, Range("c1:c2")) Is Nothing Then
Application.EnableEvents = False
MsgBox ("Foo")
ElseIf Not Intersect(target, Range("d1:d2")) Is Nothing Then
Application.EnableEvents = False
MsgBox ("Bar")
ElseIf Not Intersect(target, Range("e1:e2")) Is Nothing Then
Application.EnableEvents = False
MsgBox ("Hello World")
Else
Exit Sub
End If
MovingOn:
Application.EnableEvents = True
Exit Sub
Bummer:
MsgBox Err.Description
Resume MovingOn
End Sub
Currently I managed to do for a single cell when the specified cell is empty then message / statement display on the cell.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range("AA17").Value = ISBLANK Then
Range("AA17").Value = "Please Specify"
End If
End Sub
What I would like to do is, for a several cell it will display the same thing. I can go ahead and do the same as above for all celsl but I have a few hundred cell to format it that way.
Is there a way to do so?
If the cells are contiguous, you could loop through them.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim checkRng As Range
Dim cel As Range
Set checkRng = Range("A7:A70")
For Each cel In checkRng
If cel.Value = ISBLANK Then
cel.Value = "Please Specify"
End If
Next cel
End Sub
if there is any changes within the specified Range, the below code will run
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Rng As Range
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
Set Rng = ws.Range("A1:A100")
If Not Intersect(Target, Rng) Is Nothing Then
For Each Cell In Rng
If IsEmpty(Cell.Value) = True Then
Cell.Value = "Please Specify"
End If
Next
End If
Set Rng = Nothing
Set ws = Nothing
Set wb = Nothing
End Sub
I'm trying to write a piece of code that automatically separates the data scanned in from a plug&play scanner from a 2D bar-code. The data is in this format "SN1234567 7654321 PA01234-5 A B C" and I need each block of text/numbers into each own cell. Now I was successful in finding a macro online to split this text(shown below), and also a macro to automatically run A (not my macro) macro when entering data into A1. the problem is I cant get the worksheet_change sub to work with my splittext macro. Code shown below
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Range("A1:C10")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
' Display a message when one of the designated cells has been
' changed.
' Place your code here.
MsgBox "Cell " & Target.Address & " has changed."
Call textsplit
End If
End Sub
Sub textsplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, " ")
For a = 0 To UBound(name)
Cells(1, a + 1).Value = name(a)
Next a
End Sub
It's not really clear where you want the split values to go, but something along these lines works:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range, rng As Range
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Range("A1:C10")
'Target can be a multi-cell range, so you need to account
' for that possibility
Set rng = Application.Intersect(KeyCells, Target)
If Not rng Is Nothing Then
' Display a message when one of the designated cells has been
' changed.
' Place your code here.
Debug.Print "Cell " & Target.Address & " has changed."
'prevent re-activating this sub when splitting text...
Application.EnableEvents = False
textsplit Target
Application.EnableEvents = True
End If
Exit Sub
haveError:
Application.EnableEvents = True
End Sub
Sub textsplit(rng As Range)
Dim c As Range, arr
For Each c In rng.Cells
If Len(c.Value) > 0 Then
arr = Split(c.Value, " ")
c.Offset(0, 1).Resize(1, UBound(arr) + 1).Value = arr
End If
Next c
End Sub
I modified some of your code to use TextToColumns instead of textsplit() which works.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A1:C10")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
MsgBox "Cell " & Target.Address & " has changed."
Target.TextToColumns Destination:=Range(Target.Address), DataType:=xlDelimited, Space:=True
End If
End Sub
Once the cell was changed, the ActiveCell is no longer the target. Send the Sub the target, see below:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Range("A1:C10")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
' Display a message when one of the designated cells has been
' changed.
' Place your code here.
MsgBox "Cell " & Target.Address & " has changed."
Call textsplit(Target)
End If
End Sub
Sub textsplit(Target)
Dim text As String
Dim a As Integer
Dim name As Variant
text = Target.Value
name = Split(text, " ")
For a = 0 To UBound(name)
Cells(1, a + 1).Value = name(a)
Next a
End Sub