I've written code that first hides a range and is then supposed to unhide the relevant rows based on the value in the target range.
The hide is working, but my code doesn't unhide anything:
Sub Hide(row As Double, dExtras As Double)
'Hide rij op basis van argument
Rows(row & ":" & row + dExtras).EntireRow.Hidden = True
End Sub
Sub Unhide(row As Double, dExtras As Double)
'Unhide rij op basis van argument
Rows(row & ":" & row + dExtras).EntireRow.Hidden = False
End Sub
The code that calls these subs:
Sub AlertsShowHide()
Dim wsTemplate As Worksheet
Dim i As Long, lAantalAlerts As Long
Set wsTemplate = ThisWorkbook.Worksheets("Template")
With wsTemplate
lAantalAlerts = .Range("aantalAlerts")
'Hide all
.Range(.Range("aantalAlerts").Offset(2, 0), .Range("antVoorgaandeAlerts").Offset(-3, 0)).EntireRow.Hidden = True
'Unhide relevant alerts
For i = 1 To lAantalAlerts
'Unhide in/out/voeding rows
Call AlertsRow(.Range("antEachAlertType" & CStr(i)))
'Only works up to 6 alerts
If i = 6 Then Exit For
Next i
'Unhide extra room for process more than 6 alerts
If lAantalAlerts > 6 Then
Call Unhide(.Range("antAlertToelicht7").row, 0)
MsgBox "Bij meer dan 6 alerts handmatig de beschrijving toevoegen van deze extra alerts onderaan bij vakje 'Toelichting MEER DAN 6 alerts'", vbOKOnly, "Veel alerts"
End If
End With
End Sub
Sub AlertsRow(target As Range)
'Unhide de relevant rijen Inkomnde, Uitgaande en/of voeding afhankelijk van gekozen alert(s)
' Hide all
Call Hide(target.Offset(1, 0).row, 58)
' Unhide header
Call Unhide(target.Offset(-3, 0).row, 3)
' Unhide toelichting
Call Unhide(target.Offset(57, 0).row, 2)
'Determine which alerts to unhide
If target.Value Like "*WWFT*" Then
Call Unhide(target.Offset(1, 0).row, 3)
End If
If target.Value Like "*Credit on Card*" Then
Call Unhide(target.Offset(5, 0).row, 2)
End If
If target.Value Like "*Funding*" Then
Call Unhide(target.Offset(8, 0).row, 1)
End If
If target.Value Like "*Crypto & Trading*" Then
Call Unhide(target.Offset(10, 0).row, 3)
End If
If target.Value Like "*Gambling*" Then
Call Unhide(target.Offset(14, 0).row, 3)
End If
If target.Value Like "*Money transfer*" Then
Call Unhide(target.Offset(18, 0).row, 3)
End If
If target.Value Like "*P2P*" Then
Call Unhide(target.Offset(22, 0).row, 3)
End If
If target.Value Like "*Passing through*" Then
Call Unhide(target.Offset(26, 0).row, 3)
End If
If target.Value Like "*Activation of a dormant account*" Then
Call Unhide(target.Offset(30, 0).row, 2)
End If
If target.Value Like "*Cash*" Then
Call Unhide(target.Offset(33, 0).row, 2)
End If
If target.Value Like "*Donations*" Then
Call Unhide(target.Offset(36, 0).row, 2)
End If
If target.Value Like "*High Risk Terrorism Activities*" Then
Call Unhide(target.Offset(39, 0).row, 2)
End If
If target.Value Like "*High Risk Terrorism Countries*" Then
Call Unhide(target.Offset(42, 0).row, 2)
End If
If target.Value Like "*Sanction High Risk Offshore*" Then
Call Unhide(target.Offset(45, 0).row, 2)
End If
If target.Value Like "*Smurfen*" Then
Call Unhide(target.Offset(48, 0).row, 2)
End If
If target.Value Like "*Transfer to bank account*" Then
Call Unhide(target.Offset(51, 0).row, 1)
End If
If target.Value Like "*Trx on card*" Then
Call Unhide(target.Offset(54, 0).row, 2)
End If
End Sub
I added a watch to the target value, to see if this is correct. Which it is. So it seems the Unhide() sub is not working.
However when I try hard coding with this sub, it does work.
I think your issue may well be one of 'scope' - you have been vary careful in the main procedure AlertsShowHide() only to use explicitly-qualified Range references, and the fact that you specifically target the Template worksheet raises the possibility that it isn't necessarily the active sheet when your code runs.
Your Hide() and Unhide() procedures, on the other hand, use only numeric arguments and unqualified Range references, meaning that they will operate on whatever the active sheet happens to be at the time of execution. I propose re-factoring both of these procedures as follows
Sub Hide(start As Range, dExtras As Long)
'Hide rij op basis van argument
start.Resize(dExtras).EntireRow.Hidden = True
End Sub
and
Sub Unhide(start As Range, dExtras As Long)
'Hide rij op basis van argument
start.Resize(dExtras).EntireRow.Hidden = False
End Sub
by passing an argument of type Range you are implicitly 'telling' the procedure on which worksheet you want to do the hiding or un-hiding.
Taking as examples the first 2 calls from your AlertsRow() procedure, you would call the re-factored procedures thus
Call Hide(target.Offset(1, 0), 58)
' Unhide header
Call Unhide(target.Offset(-3, 0), 3)
(this is not answer to your problem) Use one Sub for hide and Show and parameters Long not Double:
Sub ShowOrHide(row As Long, hideflag As Boolean, dExtras As Long)
'Hide rij op basis van argument
Rows(row & ":" & row + dExtras).EntireRow.Hidden = hideflag
End Sub
Related
I'm trying to record the value that changes every one minute from cell "B2" into cell "D2". When the values are recorded to "D2" in a row, I want to add the date and time at the same time it recorded into cell "E". Here, below is my code.
Private Sub Worksheet_Calculate()
Application.EnableEvents = False
Me.Range("D" & Me.Rows.Count).End(xlUp).Offset(1).Value = Me.Range("B2").Value
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim targetRng As Range
Dim rng As Range
Dim c As Integer
Set targetRng = Intersect(Application.ActiveSheet.Range("D:C"), Target)
c = 1
If Not targetRng Is Nothing Then
Application.EnableEvents = False
For Each rng In targetRng
If Not VBA.IsEmpty(rng.Value) Then
rng.Offset(0, c).Value = Now
rng.Offset(0, c).NumberFormat = "dd/mm/yyyy, hh:mm:ss AM/PM"
Else
rng.Offset(0, c).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub
It seems that every time the value has recorded, the date and time in cell "E" do not appear to work together.
Any solution here?
I recommend creating a seperate Sub that is not directly hit by an event. Rewrite code below for your purposes.
Private Sub Worksheet_Calculate()
SharedSheetEvent()
end sub
Private Sub Worksheet_Change(ByVal Target As Range)
EditingSheet = true
call SharedSheetEvent()
editingsheet = false
end sub
global EditingSheet as bool
public Sub SharedSheetEvent()
if (EditingSheet) Then
do some stuff
else
do some other stuff
end if
end sub
The code below will do what you want. No two procedures are needed but if you don't specify the sheet, meaning you let it work on the ActiveSheet, it would be a bit of a lose cannon.
Private Sub Worksheet_Calculate()
Dim LastRecord As Range ' cell last written to
Dim NewValue As Variant ' current value in B2
Debug.Print "calculate"
With Worksheets("Sheet1") ' change to suit
Set LastRecord = .Cells(.Rows.Count, "D").End(xlUp)
NewValue = .Cells(2, "B").Value
With LastRecord
If .Value <> NewValue Then ' skip if no change
Application.EnableEvents = False
.Offset(1).Value = NewValue
With .Offset(1, 1)
.Value = Now()
.NumberFormat = "dd/mm/yyyy, hh:mm:ss AM/PM"
End With
Application.EnableEvents = True
End If
End With
End With
End Sub
The question is not, however, how the code works but when. I presume that B2 is changed by a program that works on a timer. The change generated by it doesn't trigger the Worksheet's Change event. You did find out, however, that it triggers the Calculate event. That is my presumption and I couldn't test it. If that is so my procedure will solve your problem.
I have programmed a similar thing recently using a timer of my own to trigger running my procedure. It's just a timer that runs at the same interval as the other and checks every minute (for example) if B2 has changed and records the change if there was one. That works. But if your updater triggers the Calculate event that looks like a neater idea.
I prepared the if statement for checking my cells in the specific row. I have several cells, which I have to check. Their values are mostly "x" but sometimes they vary.
The problem is, that even if one of the value is different than "x", I am still getting the msgbox, that everything is good as per the code, which I prepared.
Sub AuditCheck()
If Range("C33,C39:C40,C43,C53:C54,C57:C59,C68").Value = "x" Or Range("C33,C39:C40,C43,C53:C54,C57:C59,C68").Value = "0" Then
'Rows(39).Delete
Range("C58").Activate 'taking a look just in case
MsgBox ("All good!") ' if so we can hide X
ActiveSheet.Range("$A$5:$IF$77").AutoFilter Field:=1, Criteria1:="<>x", Criteria2:="<>0"
Else
MsgBox ("You have to change the pricing!")
If Range("C39").Value <> "x" Then 'C39 CASE
MsgBox ("Install duct Upturns/upturn section must be removed!")
Call RemoveUpturn
Call New_version_upturn
End If
Exit Sub 'the macro is terminated because you have to change the prices
End If
End Sub
Is there something, which I haven't mentioned in the code?
Try the next code, please:
Sub AuditCheck()
Dim sh As Worksheet, rng As Range, ar As Range, countX As Long, zCount As Long
Set sh = ActiveSheet
Set rng = Range("C33,C39:C40,C43,C53:C54,C57:C59,C68")
For Each ar In rng.Areas
countX = countX + WorksheetFunction.CountIf(ar, "x")
zCount = zCount + WorksheetFunction.CountIf(ar, "0")
Next
If countX = rng.cells.count Or zCount = rng.cells.count Then 'here, you maybe want adding the two counts...
Range("C58").Activate 'taking a look just in case
MsgBox ("All good!") ' if so we can hide X
ActiveSheet.Range("$A$5:$IF$77").AutoFilter field:=1, Criteria1:="<>x", Criteria2:="<>0"
Else
MsgBox ("You have to change the pricing!")
If Range("C39").Value <> "x" Then 'C39 CASE
MsgBox ("Install duct Upturns/upturn section must be removed!")
Call RemoveUpturn
Call New_version_upturn
End If
End If
End Sub
It looks strange checking of counted "x" or "0". If you wanted to count them together, you should add them an compare with total range cells count...
If counting zero does not count (anymore), you just delete the second condition.
You must use CountIf (doc here) which will counts the number of cells within a range that meets the given criteria to do that you would have done something like that :
Sub Try_Me()
Dim Myrng As Range
Dim NumCheck as Long
Dim StrCheck as String
StrCheck = "x"
NumCheck = 0
Set Myrng = Range("C33,C39:C40,C43,C53:C54,C57:C59,C68")
If WorksheetFunction.CountIf(Myrng, NumCheck ) = Myrng.Count Or WorksheetFunction.CountIf(Myrng, StrCheck ) = Myrng.Count Then
Range("C58").Activate 'taking a look just in case
MsgBox ("All good!") ' if so we can hide X
ActiveSheet.Range("$A$5:$IF$77").AutoFilter Field:=1, Criteria1:="<>x", Criteria2:="<>0"
Else
MsgBox ("You have to change the pricing!")
If Range("C39").Value <> "x" Then 'C39 CASE
MsgBox ("Install duct Upturns/upturn section must be removed!")
Call RemoveUpturn
Call New_version_upturn
End If
Exit Sub 'the macro is terminated because you have to change the prices
End If
End Sub
EDIT According to #chris neilsen you should do as below since CountIf does not work with non-contiguous range.
So I would suggest you to just count the number of X in your range if it does match with the excepted number of x or 0 the the if condition will return true :
Sub Try_Me()
Dim Myrng As Range
Dim NumCheck as Long
Dim StrCheck as String
Dim NumExceptedX as Int
Dim NumeExceptedZ
NumExceptedX = 11
NumeExceptedZ = 15
StrCheck = "x"
NumCheck = 0
Set Myrng = Range("C33:C68")
If WorksheetFunction.CountIf(Myrng, NumCheck ) = NumeExceptedZ Or WorksheetFunction.CountIf(Myrng, StrCheck ) = NumExceptedX Then
Range("C58").Activate 'taking a look just in case
MsgBox ("All good!") ' if so we can hide X
ActiveSheet.Range("$A$5:$IF$77").AutoFilter Field:=1, Criteria1:="<>x", Criteria2:="<>0"
Else
MsgBox ("You have to change the pricing!")
If Range("C39").Value <> "x" Then 'C39 CASE
MsgBox ("Install duct Upturns/upturn section must be removed!")
Call RemoveUpturn
Call New_version_upturn
End If
Exit Sub 'the macro is terminated because you have to change the prices
End If
End Sub
If the users fill in the serial no. column in col B (it doesn't have to be all 10 of them, as long as one is filled), they need to fill up the other columns from col C to col F. Hence, if col B is filled up but any of the cells in col C to F are not filled up, I want an error message to pop up. I hope the image below gives a clearer idea..:
I'm not sure if Worksheet_SelectionChange will do what I want to accomplish...because I don't want to include a command button. As some users may not bother clicking on the command button to verify their inputs. This is the code I have at the moment, please feel free to advise accordingly....thank you:)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range("B4").Value = "" Then
MsgBox "serial no. is a Mandatory field", vbExclamation, "Required Entry"
Range("B4").Select
End If
If Range("B4:B") <> "" Then
If Range("C4:C").Value = "" Then
MsgBox "Product is a Mandatory field", vbExclamation, "Required Entry"
Range("C4:C").Select
End If
' Adding values from sheet 2 for fruits drop-down list.
If Not Intersect(Target, Range("D3")) Is Nothing Then
Sheets("Sheet1").Range("D3") = "[Please Select]"
Dim col As New Collection
Dim rng As Range
Dim i As Long
Dim dvlist As String
'Loop thru the data range
For Each rng In Sheet2.Range("B2:B7")
'ignore blanks
If Len(Trim(rng.Value)) <> 0 Then
'create a unique list
On Error Resume Next
col.Add rng.Value, CStr(rng.Value)
On Error GoTo 0
End If
Next rng
'concatenate with "," as the delimiter
For i = 2 To col.Count
dvlist = dvlist & col.Item(i) & ","
Next i
With Sheet1.Range("C2:C").Validation
.Delete
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Formula1:=dvlist
End With
End If
' Adding values from sheet 2 for country of origin drop-down list.
If Not Intersect(Target, Range("E4")) Is Nothing Then
Sheets("Screening Request").Range("E4") = "[Please Select]"
'Loop thru the data range
For Each rng In Sheet2.Range("A2:A7")
'ignore blanks
If Len(Trim(rng.Value)) <> 0 Then
'create a unique list
On Error Resume Next
col.Add rng.Value, CStr(rng.Value)
On Error GoTo 0
End If
Next rng
'concatenate with "," as the delimiter for list in Sheet 2
For i = 2 To col.Count
dvlist1 = dvlist1 & col.Item(i) & ","
Next i
'add it to the DV
With Sheet1.Range("D3").Validation
.Delete
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Formula1:=dvlist1
End With
End If
' This is for the date (YYYYMMDD) column. I need it to be in YYYYMMDD format:
If Not Intersect(Target, Range("F4:F13")) Is Nothing Then
If Not IsNumeric(.Value) And Not cel.NumberFormat = "yyyymmdd" Then
MsgBox "Date format must be in YYYYMMDD"
cel.Value = ""
Exit Sub
Else: cel.NumberFormat = "yyyymmdd"
End If
End With
End If
In general, you are making life much too hard for yourself. Use the tools that Excel provides (and there are many); you do not need to re-invent the wheel.
For example the lists for fruits and country of origin in your Sheet2 should be used as a list for data validation purposes in Sheet1 (Data Tab, Data Tools, Data Validation). Choose Allow List, make sure Ignore blank and In-cell dropdown are checked and select the range from Sheet2.
Similarly you can use data validation to validate dates in your last column.
You now do not need to validate these columns yourself, as they will always have blanks or valid values.
Combine this with my suggestion of conditional formatting (eg for the range c4:c13 you should enter =AND(B4<>"",ISBLANK(C4)) and for all three columns, you can produce a very simple verification routine. Something like:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Cancel = MissingEntries()
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Cancel = MissingEntries()
End Sub
Private Function MissingEntries() As Boolean
Dim i As Integer
Dim j As Integer
Dim atLeastOneLine As Boolean
atLeastOneLine = False
For i = 4 To 13
If (Cells(i, 2) <> "") Then
atLeastOneLine = True
For j = 3 To 6
If Cells(i, j) = "" Then
MsgBox ("Please supply values for highlighted cells")
MissingEntries = True
Exit Function
End If
Next
If WrongSerialNumber(i) Then
MissingEntries = True
Exit Function
End If
End If
Next
If Not atLeastOneLine Then
MsgBox ("Please supply values for at least one line")
MissingEntries = True
Else
MissingEntries = False
End If
End Function
Private Function WrongSerialNumber(i As Integer) As Boolean
Dim yr As Integer
Dim serialNo As String
Dim yrStr As String
Dim yrCell As String
serialNo = Cells(i, 2)
If Len(serialNo) < 3 Then
WrongSerialNumber = True
MsgBox "Serial Number for row no. " + CStr(i - 3) + " is too short. Please correct."
Exit Function
End If
yrCell = Cells(i, 6)
If Len(yrCell) = 8 Then
yr = CInt(Left(Cells(i, 6), 4))
If yr > 1968 Then
If Mid(yrCell, 3, 2) <> Mid(serialNo, 2, 2) Then
WrongSerialNumber = True
MsgBox "Serial Number for row no. " + CStr(i - 3) + " has wrong second and third digits. These should match the third and fourth digits of the date. Please correct."
Exit Function
End If
End If
End If
WrongSerialNumber = False
End Function
Note that I validate on both close and save. The former is optional.
Because of the highlighting, a simple message suffices, you are spared the work of informing the user, which cells are missing. In this way the combination of in-built Data Validation and Conditional Formatting makes the remainder of your task so much easier.
I'm fairly new to VBA and looking for any advice on how to manually control the change event for the below.
Column "F" has a Vlookup that returns "Fail" or "0", and rather that having each individual code to hide the row when the single cell in column F changes to 0, I found the below to work the best.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRow As Long
If Target.Column = 6 Then
' Loop through rows 5-160
For myRow = 5 To 160
' Hide row in entry in column F is "0"
Rows(myRow).Hidden = (Cells(myRow, "F") = "0")
Next myRow
End If
End Sub
I have tried to use the below with the event change but it crashes the program and always restarts. Any suggestions would be greatly appreciated.Thanks!
Private Sub Worksheet_Calculate()
Worksheet_Change Range("F:F")
End Sub
This is my version of what you are trying to accomplish. If the values returned by the formulas in F5:F160 change, the changed values are caught by Worksheet_Calculate and only those changed values are processed by Worksheet_Change.
Caveat: This method of capturing changed values from formulas does not work well when volatile functions are in the workbook. Volatile functions include TODAY(), NOW(), OFFSET(...), etc.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("F5:F160")) Is Nothing Then
Application.EnableEvents = False
On Error GoTo meh
Dim t As Range
Debug.Print "chg: " & Intersect(Target, Range("F5:F160")).Address(0, 0)
For Each t In Intersect(Target, Range("F5:F160"))
't.EntireRow Hidden = CBool(LCase(t.Value2) = "fail" or t.Value2=0)
t.EntireRow.Hidden = CBool(LCase(t.Value2) = "fail")
Next t
End If
meh:
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Calculate()
Static effs As Variant
Dim f As Long, t As Range
If IsEmpty(effs) Then
effs = Range("F1:F160").Value2
For f = 5 To 160
If IsError(effs(f, 1)) Then effs(f, 1) = vbNullString
Next f
Else
For f = 5 To 160
If Not IsError(Cells(f, "F")) Then
If effs(f, 1) <> Cells(f, "F").Value2 Then
If Not t Is Nothing Then
Set t = Union(t, Cells(f, "F"))
Else
Set t = Cells(f, "F")
End If
effs(f, 1) = Cells(f, "F").Value2
End If
End If
Next f
If Not t Is Nothing Then
Debug.Print "calc: " & t.Address(0, 0)
Worksheet_Change t
End If
End If
End Sub
This seems to run well on a test workbook. Additional error and looping control may be necessary in your own situation.
I'm having a strange issue with Application.Run in a subprocedure that adds new rows (1 or more depending on user's choice). I wanted to separate the AddRowsBelow() sub so I can reuse it somewhere else too:
Sub AddRowsBelow(Coord As Range, RowsToAdd As Long, Optional SubName As String)
Dim i As Integer
Dim newRowNr As Integer: newRowNr = Coord.Row
For i = 1 To RowsToAdd
Coord.Offset(1).EntireRow.Insert xlDown
If LenB(SubName) <> 0 Then
newRowNr = newRowNr + 1
Application.Run SubName, newRowNr
End If
Next
End Sub
When I pass following sub as an argument, it Debug.Prints rowNr successfuly on each iteration, but the rest of the code only runs once in case of more rows – nothing happens for other iterations. It is run on a range formatted as Excel Table.
Sub FlagAsSublist(rowNr As Integer)
Sheet2.Cells(rowNr, 1).Value = ChrW(sublistFlag)
Debug.Print rowNr
Sheet2.Range(Cells(rowNr, 4), Cells(rowNr, 11)).Borders(xlInsideVertical).ColorIndex = 2
End Sub
Any ideas why it does not work?