Can someone modify my code so that the message box will only show once?
I've been at it for a while now without succes.
The file I'm working on is a register. Whenever the sum of AD13:AJ13 exceed 4 the msg should show,
Prompting action from the user. However as of now, once a cell within the range have exceeded 4 the msgbox shows on all changes within the range, even sums below 4. That's is not intended, i only want the user to be notified once for each cell within the range (AD13:AJ13)
Code:
Private Sub Worksheet_Calculate()
Dim myCell As Range
For Each myCell In Range("AD13:AJ13")
If myCell > 4 Then
MsgBox "Management approval is required once the value exceed 4"
Exit Sub
End If
Next myCell
End Sub
I kind of agree with the comments below the question as Worksheet_Change seems like a more natural trigger. However, the problem could be that this range is not changed directly (i.e. cells have formulae which could depend on cells from other sheets or even other workbooks).
You basically need to somehow save the current state of these cells. Please try this code and see if it helps or opens up a new window of ideas for you.
Private Sub Worksheet_Calculate()
Dim rngSavedState As Range
Dim j As Integer
Dim bMsgBoxShown As Boolean
Set rngSavedState = Range("AD14:AJ14")
Application.EnableEvents = False
With Range("AD13:AJ13")
bMsgBoxShown = False
For j = 1 To .Columns.Count
If .Cells(1, j).Value <> rngSavedState.Cells(1, j).Value Then
rngSavedState.Cells(1, j).Value = .Cells(1, j).Value
If .Cells(1, j) > 4 And Not bMsgBoxShown Then
MsgBox "Management approval is required once the value exceed 4"
bMsgBoxShown = True
End If
End If
Next j
End With
Application.EnableEvents = True
End Sub
You obviously need to change the address of rngSaveState to suit your application.
All the best
Related
I'm trying to generate a code that will fill cells in a row based on the input of the selected cell. In a nutshell, there's 6 steps and the goal is to type "Step 6" in one cell and have Steps 5-1 generate in the 5 cells to the right, however the code cannot be restricted to a fixed cell and must move relative to the first cell selected. Is this possible? Ive used the week autofill as reference below but am lost.
Sub Weekday_Data_Update()
Dim startRange As Range
Dim stopRange As Range
Set startRange = Sheets("Sheet1").Range("A2")
'Specify the cell until which you want weekdays to be displayed
Set stopRange = Sheets("Sheet1").Range("A2:A6") startRange.Select
Selection.AutoFill Destination:=stopRange, Type:=xlFillWeekdays
End Sub
Like this (code goes in the worksheet module)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim v, i As Long
If Target.CountLarge > 1 Then Exit Sub 'only tracking single-cell changes
v = Target.Value
If IsError(v) Then Exit Sub 'cell has error - exit
If v = "Step 6" Then
For i = 5 To 1 Step -1
Target.Offset(0, 6 - i).Value = "Step " & i
Next i
End If
End Sub
i have main user-form 1 which has all the information including list box and when user select the name of the person it will find for duplicate and if user press Yes to duplicate msgbox another user-form 2 will popup requiring password and if user enters the correct password it will popup another user-form 3 which has comment box to be updated against initial duplicate find..
problem is that it only updates comment on 1st line row on sheet 1 (where the data updates) and NOT the actual duplicate it finds using staff ID number in column G in sheet1. it only finds first line which is within User-form1 listbox not the line you have selected in User-form1.
below it is the code which works fine within User-form1 and however it dose not work of what i wants to work when placed in user-form 3
Private Sub CommandButton1_Click()
Dim p As Variant
Dim lCol As Variant
Dim response As Variant
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Jobs_Allocation")
Dim y As Long
Application.EnableCancelKey = xlDisabled
If TextBox1 > False Then
Unload Me
lCol = frmSelector.lstSelector.List(x, 3)
Set findvalue = Sheet1.Range("G:G").Find(What:=lCol, LookIn:=xlValues)
If Not findvalue Is Nothing Then
adr = findvalue.Address
Do
Sheet1.Unprotect Password:="123"
If findvalue.Offset(0, -1).Value = frmSelector.lstSelector.List(x, 2) Then
findvalue.Offset(0, 6).Value = Format(Now, "HH:MM:SS")
findvalue.Offset(0, 7).Value = TextBox1.Value
y = sh.Range("C" & Application.Rows.Count).End(xlUp).Row
Exit Do
End If
Set findvalue = Sheet1.Range("G:G").FindNext(findvalue)
Loop While findvalue.Address <> adr
Set findvalue = Nothing
End If
End If
If TextBox1.Value > 0 Then
MsgBox "You must enter the comment", vbCritical, "Error message"
Exit Sub
End If
End Sub
I'm sorry as I'm not helping you thouroghly, but I think you need to do the loop in your CommandButton1_Click which reside in the third Userform.
I give you a very simple simulation which I hope you can implement it to your code.
From the image above, it's the first userform, in your case it's frmselector.
The listbox is named to lstselector, and (in the image) the selected item is the fourth row. So, the index number is 3, the x value in your case.
I see that to get the lCol value, you do the code :
For x = 0 To Me.lstSelector.ListCount - 1
If Me.lstSelector.Selected(x) Then
**If Me.txtJob.Value = Value = False Then**
lCol = Me.lstSelector.List(x, 3)
So, disregarding the code-line I put in between two asterisk,
based on the image above, we know that the value of the lCol variable is 80.
To get the lCol value (in other words, to get the selected value on the fourth column of the lstselector in frmselector/first_userform) when running the CommandButton1_Click sub of the third userform, we need to do the loop again. Below is the example of the code, which we hope that the code will give lCol value as 80 :
Private Sub CommandButton1_Click()
With frmselector
For x = 0 To .lstselector.ListCount - 1
If .lstselector.Selected(x) Then Exit For
Next
lCol = .lstselector.List(x, 3)
End With
MsgBox "The value of selected selector in frmselector is: " & lCol
End Sub
Manual - Select range, execute Sub
How it works - Sub saves all non-blank cells to finalArray that is ultimately displayed in the selected range
What's the problem - if range contains cells with hyperlinks created via insert-hyperlink, the hyperlinks disappear.
Sub RemoveBlanks()
'i,j - counters, k - offset
Dim finalArray() As Variant
ReDim finalArray(Selection.Rows.Count, 1)
k = 1
For i = 1 To Selection.Rows.Count
If Selection(i, 1) <> "" Then
finalArray(k, 1) = Selection(i, 1)
k = k + 1
End If
Next i
Application.ScreenUpdating = False
Application.EnableEvents = False
Selection.Clear
For i = 1 To k
Selection(i, 1).Value = finalArray(i, 1)
Next i
End Sub
This Code will loops through each cell in the selected range, checks if the cell has a hyperlink then temporarily grab and store the address that it’s pointing to re-apply the hyperlink
Option Explicit
Sub fixHyperlinks()
Dim rng As Range
Dim address As String
Application.ScreenUpdating = False
For Each rng In Selection
If rng.Hyperlinks.Count > 0 Then
address = rng.Hyperlinks(rng.Hyperlinks.Count).address
rng.Hyperlinks.Add Anchor:=rng, _
address:=address
End If
Next
Application.ScreenUpdating = True
End Sub
After you run this code, you should be able to set in your array the range without losing your links.
Conclusion : Run this code before you run your macro.
So I have found a way around the issue after lurking through internet and trying to save links in another array (fails). It works only if the value in the cell is the same as name of a sheet, yet it solves my issue so far.
Sub CreateLinks()
'i - counter, the title as i=1 is omitted. Code uses value stored in cell to
'transform it into a link.
Dim i As Integer
For i = 2 To Selection.Rows.Count
If Selection(i) <> "" Then
ActiveSheet.Hyperlinks.Add anchor:=Selection(i), _
address:="#'" & CStr(Selection(i)) & "'!A1", _
TextToDisplay:=CStr(Selection(i))
End If
Next i
End Sub
So I have a table with conditional formatting already setup (attached).
The values are being highlighted in red when greater than +/-35mm for each constituent separately (dE, dN, dH).
what I'm looking for is to create a userform so the user don't have to navigate to manage rules, instead the threshold for each constituent can be changed directly from the userform.
attached is also a photo of what I need Needed
All help greatly appreciated.
conditional_formatting
not sure what you are asking for but my understanding is you want to click on that record and edit it on a user form and you have your spread sheet already formatted.Use this code to achieve that.
place this code behind your sheet in VBA editor(the one with the data to be manipulated)
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'##################################################
'# Intercept a double click in the record area #
'# and open the edit form 36 #
'##################################################
If Target.Column > 65 Or Target.Row < 1 Then
Exit Sub
End If
Cancel = True
EditRecord
End Sub
and place this one on a module
Sub EditRecord()
Dim CurRow As Integer, CurCol As Integer, intCount1 As Long
Dim RecordEntry
Dim iRow As Long
CurRow = ActiveCell.Row
Range("A" & CurRow).Select
' check if empty row - if so call new record
With ActiveCell
If ActiveCell.Value = "" Then
' check empty rows and create new record goto_empty_row
UserForm1.Show
Exit Sub
End If
End With
' edit existing record - populate form
With UserForm1
.TextBox1.Value = ActiveCell.Offset(0, 0)
.TextBox2.Value = ActiveCell.Offset(0, 1)
.TextBox3.Value = ActiveCell.Offset(0, 2)
.Show
End With
End Sub
and then this on your user form
Private Sub CommandButton1_Click()
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet2") 'name of the Sheet
'copy the data to the spread sheet
ws.Cells(ActiveCell.Row, 1).Value = Me.TextBox1.Value
ws.Cells(ActiveCell.Row, 2).Value = Me.TextBox2.Value
ws.Cells(ActiveCell.Row, 3).Value = Me.TextBox3.Value
End Sub
I´m trying to create an Excelsheet that runs multiple VBA scripts after writing anything in A Column.
One part I would like some help with is that the character 2,3 and 4 written in A column (any row) should be written i D column same row.
I also would like to remove any information i D Column if I remove the text from A Column.
I have manage to create a script that calls modules after writing information i a cell in A Column
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Me.Range("A:A")) Is Nothing Then Exit Sub
Application.EnableEvents = False 'to prevent endless loop
On Error GoTo Finalize 'to re-enable the events
Call Modul1.Module
Finalize:
Application.EnableEvents = True
End Sub
Any help would be much appriciated.
This is what I have for now.
It doesn´t work to clear value on all rows only some of them?!
Sub Lokation()
Dim n As Long, i As Long, j As Long
n = Cells(Rows.Count, "A").End(xlUp).Row
j = 2
For i = 2 To n
If Cells(i, "A").Value = vbNullString Then
Cells(j, "D").Value = ("")
Else
Cells(j, "D").Value = Mid(Cells(j, "A").Value, 2, 3)
End If
j = j + 1
Next i
End Sub
You can wrap this whole piece up in just the Worksheet_Change event if you use the following:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim columnAcell As Range
If Intersect(Target, Me.Range("A:A")) Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each columnAcell In Target.Cells
columnAcell.Offset(0, 3) = Mid(columnAcell, 2, 3)
Next
Application.EnableEvents = True
End Sub
Instead of specifically writing to column D, I've used a cell offset of 3 columns from Target. As this code only looks at column A currently, it will always offset to column D.
Things to watch out for though -
Altering cell(A1) which contains the header would result in cell(D1) being altered. You can prevent this by changing the Intersect range from A:A to something like A2:Axxxx
Deleting the entirety of column A would result in the loop running for a very long time, not to mention causing column D to move to column C. You may want to prevent users from being able to do this.