I have a worksheet (sheet1) which contains a cell A1 with formula ='sheet2'!D10. I would like to run a macro each time cell A1 in sheet1 changes (as a result of a change in D10 in sheet2). sheet2 is streaming financial data.
Because it is a change in value, Worksheet_Change does not trigger an event. I also can't seem to find a solution with Worksheet_Calculate.
In my research, the closest solution I could find was offered here, but I have not been able to successfully implement it.
You are going to have to use Worksheet_Calculate. It's unclear on whether the 'streaming' will trigger a Worksheet_Calculate in Sheet2 but the linked cell in Sheet1 will definitely trigger a Worksheet_Calculate in that worksheet's private code sheet providing you have calculation set to automatic.
You need a variable that will hold previous values of Sheet1!A1 that can be compared to the current value of Sheet1!A1. Some prefer to use a public var declared in a public module's declaration area; I prefer to use a static var within Sheet1's Worksheet_Calculate itself.
From Microsoft Docs,
Normally, a local variable in a procedure ceases to exist as soon as the procedure stops. A static variable continues to exist and retains its most recent value. The next time your code calls the procedure, the variable is not reinitialized, and it still holds the latest value that you assigned to it. A static variable continues to exist for the lifetime of the class or module that it is defined in.
The first issue is seeding the static variable for its first use. A variant-type variable that has never been given a value report True when tested with IsEmpty so when the workbook is first opened, the first calculation cycle will simply record the value of Sheet1!A1 into the static var. Any future calculation cycle will compare the value in Sheet1!A1 to the value held in the static var and if they are different, the external sub procedure ('... run a macro ...' according to your question's narrative) will be run and the new value of Sheet1!A1 will be stored in the static var. In this way, any change in the value returned by the formula in Sheet1!A1 will force a calculation cycle, hence the worksheet's Worksheet_Calculate event sub procedure which will in turn run your external sub procedure.
In Sheet1's private code sheet
Option Explicit
Private Sub Worksheet_Calculate()
Static s2d10 As Variant
If IsEmpty(s2d10) Then
'load static var with expected value
s2d10 = Cells(1, "A").Value2
ElseIf s2d10 <> Cells(1, "A").Value2 Then
'run sub procedure here
'... run a macro ...'
'load A1's current value into the static var
s2d10 = Cells(1, "A").Value2
End If
End Sub
Selection_Change & Change
I went into a different direction and got lost. I think there might be some useful stuff in here, so here's the code anyway. It could be working in most conditions, just lose the 'str1' lines.
The 'str1' lines are for debugging purposes and show the behavior of the cells at different conditions.
Not sure if the sub ChangeD10 is emulating your conditions.
Throwing in the towel, but would appreciate any pinpointing of errors in the code.
Option Explicit
Private TargetValue As Variant
Private TargetAddress As String
Private Sub Worksheet_Change(ByVal Target As Range)
'The Playground
Const cStrWs1 As String = "Sheet1"
Const cStrWs2 As String = "Sheet2"
Const cStrCell1 As String = "A1"
Const cStrCell2 As String = "D10"
'Other Variables
Dim oWs1 As Worksheet
Dim oWs2 As Worksheet
Dim oRng As Range
Dim varA1_Before As Variant
Dim varA1_Now As Variant
'Debug
Const r1 As String = vbCr
Dim str1 As String
'Initialize
Set oWs1 = ThisWorkbook.Worksheets(cStrWs1)
Set oWs2 = ThisWorkbook.Worksheets(cStrWs2)
Set oRng = oWs2.Range(cStrCell2)
varA1_Before = oWs1.Range(cStrCell1).Value
str1 = "Worksheet_Change"
'Play
If Target.Address = oRng.Address Then
If Target.Value <> TargetValue Then
varA1_Now = oWs2.Range(cStrCell2).Value
oWs1.Range(cStrCell1).Value = varA1_Now
str1 = str1 & r1 & Space(1) & "Cell '" & cStrCell2 & "' changed " _
& "(Target.Value <> TargetValue)" & r1 & Space(2) _
& "Before: TargetValue (" & TargetAddress & ") = '" _
& TargetValue & "'," & r1 _
& " varA1_Before (" & Range(cStrCell1).Address _
& ") = " & varA1_Before & "'," & r1 & Space(2) _
& "Now: Target.Value (" & Target.Address & ") = '" _
& Target.Value & "'," & r1 _
& " varA1_Now (" & Range(cStrCell1).Address _
& ") = " & varA1_Now & "'."
Else
str1 = str1 & r1 & Space(1) & "Cell '" & cStrCell2 _
& "' didn't change. TargetValue = '" & TargetValue _
& "' and Target.Value = '" & Target.Value & "'."
End If
Else
str1 = str1 & r1 & Space(1) & "Cell '" & cStrCell2 _
& "' not changed. The Target.Address is '" _
& Target.Address & "', TargetValue is '" & TargetValue _
& "' and Target.Value is '" & Target.Value & "'."
End If
Debug.Print str1
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const r1 As String = vbCr
Dim str1 As String
str1 = "Worksheet_SelectionChange"
If Target.Cells.Count = 1 Then
str1 = str1 & r1 & Space(1) & "Cell '" & Target.Address _
& "' selected " & r1 & Space(2) _
& "Before: TargetValue (" & TargetAddress & ") = '" _
& TargetValue & "'," & r1 & Space(2) _
& "Now: Target.Value (" & Target.Address & ") = '" _
& Target.Value & "'."
TargetValue = Target.Value
TargetAddress = Target.Address
Else
str1 = str1 & r1 & Space(1) & "Multiple cells in range '" _
& Target.Address & "'."
End If
Debug.Print str1
End Sub
Sub ChangeD10()
ThisWorkbook.Worksheets("Sheet2").Cells(10, 4) = 22
End Sub
Related
I am using the following in a macro to add a comment when a cell value is changed:
Private Sub Worksheet_Change(ByVal Target As Range)
Const xRg As String = "C4:AK100"
Dim strOld As String
Dim strNew As String
Dim strCmt As String
Dim strCmt2 As String
Dim Cell As Range
Dim rngComm As Range
Dim ws As Worksheet`your text`
Dim c As Range
Dim Comment As CommentThreaded
With Target(1)
If Intersect(.Cells, Range(xRg)) Is Nothing Then Exit Sub
strNew = .Text
Application.EnableEvents = False
Application.Undo
strOld = .Text
.Value = strNew
Application.EnableEvents = True
strCmt = "Uppdated: " & Format$(Now, "YYYY/ MM/ DD ") & Chr(10) & "By: " & _
Application.UserName & Chr(10) & "Before update : " & strOld
If Target(1).CommentThreaded Is Nothing Then
.AddCommentThreaded (strCmt)
ActiveCell.CommentThreaded.Resolved = True
strCmt2 = "Updated: " & Format$(Now, "YYYY/ MM/ DD ") & Chr(10) & "By: " & _
Application.UserName & Chr(10)
Range("AM3").Value = strCmt2
Range("AM2").Value = Now
Range("AM2").NumberFormat = "YYYY-MM-DD"
Else
ActiveCell.ClearComments
strCmt = "Updated: " & Format$(Now, "YYYY/ MM/ DD ") & Chr(10) & "By: " & _
Application.UserName & Chr(10) & "Before update : " & strOld
If Target(1).CommentThreaded Is Nothing Then
.AddCommentThreaded (strCmt)
ActiveCell.CommentThreaded.Resolved = True
Range("AM3").Value = strCmt2
Range("AM2").Value = Now
Range("AM2").NumberFormat = "YYYY-MM-DD"
End If
End If
End With
End Sub
I would like to add a function so when the macro is triggered get and output the information of the first cell in the same row and column ("Name" and "Place") in a separate cell ("AM2")
I used to google, read forums but didn't find any solution
Sorry for the confusion but what i ment is Column B starting from cell B4 and downwards contains names and row 3 starting at C3 contain city names, what I would like is to display the name and the city in cell AN2 when I change a value in any cell in range C4:AK100 .
worksheet
I have written the below code in excel vba to log changes made in sheets to the change log sheet. I want to disable that sub if a check box is checked.
This code works perfectly for what I need it to do, just need to figure out a sub that does not allow this to run if a box is checked so every change is not being logged when necessary.
'declare global variable
Dim oldValue As String
Dim oldAddress As String
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'declare variables for individual sheets
Dim sheet1 As String
NSWCCDFY22M = "Sheet 1"
Dim sheet2 As String
NSWCCDFY23M = "Sheet 2"
Dim sheet3As String
NSWCCDLSW = "Sheet 3"
'Logs change for any sheet that isnt the log itself (address, values, user, date/time, hyperlink, note)
If ActiveSheet.Name <> "ChangeLog" Then
Application.EnableEvents = False
Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = ActiveSheet.Name & " – " & Target.Address(0, 0)
Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = oldValue
Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = Target.Value
Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 3).Value = Environ("username")
Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 4).Value = Now
'hyperlink to specific sheet
If ActiveSheet.Name = Sheet 1 Then
Sheets("ChangeLog").Hyperlinks.Add Anchor:=Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 5), Address:="", SubAddress:="'" & Sheet 1 & "'!" & oldAddress, TextToDisplay:=oldAddress
ElseIf ActiveSheet.Name = Sheet 2 Then
Sheets("ChangeLog").Hyperlinks.Add Anchor:=Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 5), Address:="", SubAddress:="'" & Sheet 2 & "'!" & oldAddress, TextToDisplay:=oldAddress
ElseIf ActiveSheet.Name = Sheet 3 Then
Sheets("ChangeLog").Hyperlinks.Add Anchor:=Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 5), Address:="", SubAddress:="'" & Sheet 3 & "'!" & oldAddress, TextToDisplay:=oldAddress
End If
'input box for note
Dim commentChange As String
commentChange = InputBox("Please enter a note for this change.", "Logging")
Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 6).Value = commentChange
'if input box is not filled in
If LenB(commentChange) = 0 Then
MsgBox "You must enter a note for the change you've just made." & vbCrLf & " " & vbCrLf & "You will be taken to the Change Log to add a note and can navigate back to this sheet using the link associated with your change.", vbExclamation, "Change Log Required Actions"
Sheets("ChangeLog").Select
'go to log if a note is not put in
Dim lRow As Long
Dim lColumn As Long
lRow = Range("A1").End(xlDown).Row
lColumn = Range("A1").End(xlToRight).Column
Cells(lRow, lColumn).Select
Dim OutPut As Integer
'infobox when taken to log
OutPut = MsgBox("1. Please enter a note for the change you've just made." & vbCrLf & " " & vbCrLf & "2. Click the link in the 'Link' Column to return to the previous sheet where the change was made.", vbInformation, "Change Log Required Actions")
End If
Sheets("ChangeLog").Columns("A:G").AutoFit
Application.EnableEvents = True
End If
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Count = 1 Then
oldValue = Target.Value
End If
oldAddress = Target.Address
End Sub
I have code to check empty cells in a range. I need those empty cell numbers to appear in a MsgBox.
Sub IsEmptyRange()
Dim cell As Range
Dim bIsEmpty As Boolean
bIsEmpty = False
For Each cell In Range("B1:B19")
If IsEmpty(cell) = True Then
bIsEmpty = True
Exit For
End If
Next cell
If bIsEmpty = True Then
MsgBox "There are empty cells in your range"
'I NEED THE EMPTY CELLS TO APPEAR IN THE ABOVE MSGBOX
End If
End Sub
Just use:
msgbox Range("B1:B19").SpecialCells(xlCellTypeBlanks).Address
This solution adapts your code.
Dim cell As Range
Dim emptyStr As String
emptyStr = ""
For Each cell In Range("B1:B19")
If IsEmpty(cell) Then _
emptyStr = emptyStr & cell.Address(0, 0) & ", "
Next cell
If emptyStr <> "" Then MsgBox Left(emptyStr, Len(emptyStr) - 2)
If the cell is empty, it stores the address in emptyStr. The if condition can be condensed as isEmpty returns a Boolean.
Please try this code.
Sub ListEmptyCells()
Dim Rng As Range
Dim List As Variant
Dim Txt As String
Set Rng = Range("B1:B19")
On Error Resume Next
List = Rng.SpecialCells(xlCellTypeBlanks).Address(0, 0)
If Err Then
Txt = "There are no empty cells in" & vbCr & _
"the examined range."
Else
Txt = "The following cells are empty." & vbCr & _
Join(Split(List, ","), vbCr)
End If
MsgBox Txt, vbInformation, "Range " & Rng.Address(0, 0)
Err.Clear
End Sub
It uses Excel's own SpecialCells(xlCellTypeBlank), avoiding an error which must occur if this method returns nothing, and presenting the result in a legible format created by manipulating the range address if one is returned.
List blanks via dynamic arrays and spill range reference
Using the new dynamic array possibilities of Microsoft 365 (writing e.g. to target C1:C? in section b))
=$B$1:$B$19=""
and a so called ►spill range reference (as argument in the function Textjoin(), vers. 2019+ in section c))
C1# ' note the `#` suffix!
you could code as follows:
Sub TestSpillRange()
With Sheet1
'a) define range
Dim rng As Range
Set rng = .Range("B1:B19")
'b) check empty cell condition and enter boolean values into spill range C1#
.Range("C1").Formula2 = "=" & rng.Address & "="""""
'c) choose wanted values in spill range and connect them to result string
Dim msg As Variant
msg = Evaluate("TextJoin("","",true,if(C1#=true,""B""&row(C1#),""""))")
MsgBox msg, vbInformation, "Empty cells"
End With
End Sub
Find Blank Cells Using 'SpecialCells'
The 2nd Sub (listBlanks) is the main Sub.
The 1st Sub shows how to use the main Sub.
The 3rd Sub shows how SpecialCells works, which on one hand might be considered
unreliable or on the other hand could be used to one's advantage.
After using the 3rd Sub, one could conclude that SpecialCells 'considers' only cells at the intersection of the UsedRange and the 'supplied' range.
The Code
Option Explicit
Sub testListBlanks()
Const RangeAddress As String = "B1:B19"
Dim rng As Range: Set rng = Range(RangeAddress)
listBlanks rng
listBlanks rng, True
End Sub
Sub listBlanks(SourceRange As Range, _
Optional useList As Boolean = False)
Const proc As String = "'listBlanks'"
On Error GoTo clearError
Dim rng As Range: Set rng = SourceRange.SpecialCells(xlCellTypeBlanks)
Dim msgString As String
GoSub writeMsg
MsgBox msgString, vbInformation, "Blank Cells Found ('" & proc & "')"
Exit Sub
writeMsg:
msgString = "Blank Cells in Range '" & SourceRange.Address(False, False) _
& "'" & vbLf & vbLf & "The cells in range '" _
& rng.Address(False, False) & "' are blank."
If useList Then GoSub writeList
Return
writeList:
Dim cel As Range, i As Long, CellList As String
For Each cel In rng.Cells
CellList = CellList & vbLf & cel.Address(False, False)
Next cel
msgString = msgString & vbLf & vbLf _
& "The range contains the following " & rng.Cells.Count _
& " empty cells:" & vbLf & CellList
Return
clearError:
If Err.Number = 1004 And Err.Description = "No cells were found." Then
MsgBox "No blank cells in range '" & SourceRange.Address(False, False) _
& "' were found.", vbInformation, "No Blanks ('" & proc & "')"
Exit Sub
Else
MsgBox "An unexpected error occurred." & vbLf _
& "Run-time error '" & Err.Number & "': " & Err.Description, _
vbCritical, "Error in " & proc
End If
End Sub
Sub testUsedRangeAndSpecialCells()
Const wsName As String = "Sheet2"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
With ws
.Range("A:B").ClearContents
Debug.Print .UsedRange.Address
.Cells(1, 1).Value = 1
Debug.Print .UsedRange.Address
.Cells(1, 2).Value = 2
Debug.Print .UsedRange.Address
.Cells(2, 1).Value = 1
Debug.Print .UsedRange.Address
.Cells(2, 2).Value = 2
Debug.Print .UsedRange.Address
.Cells(2, 3).Value = 3
Debug.Print .UsedRange.Address
.Cells(2, 3).ClearContents
Debug.Print .UsedRange.Address
.Cells(1, 2).ClearContents
Debug.Print .Columns("B").SpecialCells(xlCellTypeBlanks).Address
Dim rng As Range: Set rng = .Columns("C")
Debug.Print rng.Address
On Error Resume Next
Set rng = rng.SpecialCells(xlCellTypeBlanks)
If Err.Number <> 0 Then
MsgBox "We know that all cells are blank in range '" _
& rng.Address(False, False) & "', but 'SpecialCells' " _
& "doesn't consider them since they are not part of 'UsedRange'."
Debug.Print "No blank cells (not quite)"
Else
Debug.Print rng.Address
End If
On Error Goto 0
.Cells(3, 4).Value = 4
Set rng = rng.SpecialCells(xlCellTypeBlanks)
Debug.Print rng.Address(False, False)
End With
End Sub
The result of the 3rd Sub (testUsedRangeAndSpecialCells)
$A$1
$A$1
$A$1:$B$1
$A$1:$B$2
$A$1:$B$2
$A$1:$C$2
$A$1:$B$2
$B$1
$C:$C
No blank cells (not quite)
C1:C3
I am trying to figure out how to avoid the multiple msgboxes which appear when I run my code:
Public Function IsItGood(aWord As Variant) As Boolean
Dim s As String
s = "|"
tmp = s & aWord & s
patern = ""
For i = 1 To 100
patern = patern & s & i
Next i
For i = 1 To 10
patern = patern & s & "C" & i
Next i
patern = patern & s & "merge|complete framed|width|border left|border right" & s
If InStr(1, patern, tmp) > 0 Then
IsItGood = True
Else
IsItGood = False
End If
End Function
Above is the function which is used in the below worksheet_change:
Sub Worksheet_Change(ByVal Target As Range)
Dim BigS As String
Dim arr As Variant
Dim a As Variant
If Intersect(Range("G3:G19"), Target) Is Nothing Then Exit Sub
arr = Split(Target, " ")
If IsItGood(a) Then
MsgBox (" In row" + Target.Address(0, 0)) & vbCrLf & a & vbCrLf + "are ok"
Else
MsgBox Target.Address(0, 0) & vbCrLf & a & vbCrLf & "has bad stuff"
Application.Undo
End If
End Sub
The first "for" loops the 100 integers and the second from C1 to C10 and the msgbox is repeated for each splitted string.Is there a way to prevent the multiple msgboxes so only one msgbox to appear at a time. And also an "out of stack space" error appears because of the recursion.
Set at the beginning: Application.EnableEvents = False and set it to True at the end. Recursion occurs, because you are calling macro on change event of workbook, which also generates this event, thus the method is calling itself, thus recursion.
How do you properly construct a VLOOKUP statement in Excel VBA when using the ExecuteExcel4Macro function in VBA?
I have a function that successfully looks up a value in another excel workbook without opening it using ExecuteExcel4Macro, but when I attempt to change the statement to a VLOOKUP statement I get a Run-time error 1004:
The function:
Public Function fGetValueTest(sFilePath, sFileName, sSourceSheet, sSourceCell, vVal, Col)
'Returns the value of a cell from a closed file [BD]
'Declaring variables [BD]
Dim sStringMacro As String
Dim externalValue As Variant
'Setting variables [BD]
externalValue = ExecuteExcel4Macro("'" & sFilePath & "[" & sFileName & "]" & sSourceSheet & "'!" & _
Range("A1").Range(sSourceCell).Address(, , xlR1C1))
'Exception error on file not found [BD]
If Dir(sFilePath & sFileName) = "" Then
fGetValueTest = "File Not Found!"
Exit Function
End If
'If value of source cell is N/A [BD]:
If Application.IsNA(externalValue) Then
'Skip and move on [BD]
fGetValueTest = "0"
ElseIf IsError(externalValue) Then
MsgBox "Error - Check fGetValue Function"
Else
'Creating macro variable [BD]
sStringMacro = "'" & sFilePath & "[" & sFileName & "]" & sSourceSheet & "'!" & _
Range("A1").Range(sSourceCell).Address(, , xlR1C1)
fGetValueTest = ExecuteExcel4Macro("Vlookup(" & vVal & "," & sStringMacro & "," & Col & ",0)")
End If
End Function
And it's usage in the subroutine:
Sub TestGetValue()
Dim sFileName As String
Dim sFilePath As String
Dim sSourceSheet As String
Dim sSourceCell As String
Dim sDestinationCell As String
Dim sDestinationSheet As String
Dim vVal As String
Dim Col As String
sFileName = "0306-0312 Margin Master.xlsx"
sFilePath = "\\store\GroupDrives\Pricing\_Deli_\Deli Fresh Shift\Margin Master\"
sSourceSheet = "Bakery"
sDestinationSheet = "TestSheet"
sSourceCell = "G10"
sDestinationCell = "G10"
vVal = "A10"
Col = 3
ThisWorkbook.Worksheets(sDestinationSheet).Range(sDestinationCell) = fGetValueTest(sFilePath, sFileName, sSourceSheet, sSourceCell, vVal, Col)
End Sub
I don't see any errors in how the VLOOKUP statement is constructed, does ExecuteExcel4Macro require a different type of statement or is there something else going on here?
Any help would be greatly appreciated, and if anyone happens to know if there is a manual for ExecuteExcel4Macro or any documentation of any real value that would also be helpful!
This is a possibility if it can be adopted:
Function:
Public Function GetVlookup(path, file, sheet, ref, Col, vVal)
' Retrieves a value from a closed workbook
Dim arg As String
' Make sure the file exists
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetVlookup = "File Not Found"
Exit Function
End If
If IsNumeric(vVal) Then
vVal = CDbl(vVal)
Else
vVal = Chr(34) & vVal & Chr(34)
End If
' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Address(, , xlR1C1)
' Execute an XLM macro
GetVlookup = ExecuteExcel4Macro("Vlookup(" & vVal & "," _
& arg & "," & Col & ",0)")
End Function
Subroutine:
Sub TestThingSub()
Dim Varr As Variant
Varr = GetVlookup("\\store\GroupDrives\Pricing\_Deli_\Deli Fresh Shift\Margin Master\", "0306-0312 Margin Master2.xlsx", "Sheet2", "A1:B26", 2, "HORSE")
MsgBox Varr
End Sub