when I am trying to execute this code it only executes the part after Exit Sub , only the foreach loop is executed, when the sheet is unprotected. I think it is caused by the Exit Sub. My problem is that I want to execute to different codes one when the sheet is protected (for each cell in Range("B6:B112..)) and the other(starting at Dim rng as Range..) when the sheet is unprotected. I tried If..Then..Else but that does not work.
Private Sub Worksheet_Change(ByVal Target As Range)
If Worksheets("test").ProtectContents Then Exit Sub
For Each cell In Range("B6:B112")
If cell.Value <> "" Then
cell.EntireRow.Hidden = False
Else
cell.EntireRow.Hidden = True
End If
Next cell
Dim rng As Range
Dim eingabeNr As Double, letzteZeile As Long, eingabeDatum As String, eingabeNrString As String
Set rng = Range("D:BC")
THX.
Private Sub Worksheet_Change(ByVal Target As Range)
If Worksheets("test").ProtectContents = True Then 'added = true for readability.
For Each cell In Range("B6:B112")
If cell.Value <> "" Then
cell.EntireRow.Hidden = False
Else
cell.EntireRow.Hidden = True
End If
Next cell
Else
Dim rng As Range
Dim eingabeNr As Double, letzteZeile As Long, eingabeDatum As String,_
eingabeNrString As String
Set rng = Range("D:BC")
Do some stuff here
End if
Related
In my office we tally bags with a barcode scanner, but some times the user edits the Excel cell, giving the bag number manually, so I want to stop manually writing in excel cell.
That cell must update only by scanner.
I've tried the code below, and it returns the keystroke count but not the time.
Private Sub Worksheet_Change(ByVal Target As Range)
'If Target.Address = Range("A1:A100") Then
'Enter Code or Call any Function if any process has to be performed
'When someone Edits the cell A1
If Range(ActiveCell, ActiveCell.Offset(numRows, numCols)).Offset.Value = "" Then
Call Demo
Else: End If
End Sub
Sub Demo()
'Specify a range (change to suit)
MsgBox CountKeystrokes(Sheets("Sheet1").Range("A:A"))
If Range(ActiveCell, ActiveCell.Offset(numRows, numCols)).Offset.Value <> "" Then
Range(ActiveCell, ActiveCell.Offset(numRows, numCols)).Select
Selection.ClearContents
Else
End If
End Sub
Function CountKeystrokes(rng As Range) As Long
Dim rCell As Range
Dim iCtr As Long
For Each rCell In rng
iCtr = iCtr + Len(rCell.Formula)
Next
CountKeystrokes = iCtr
End Function
I am trying to run this worksheet change event for two different columns(A) and (I)...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
r.Offset(0, 1).Value = Date
Next r
Application.EnableEvents = True
End Sub
This event is something i found on this forum. Its purpose is to make it so whenever data is ever entered into column "a" it auto inputs the date into the cell directly right of it. I want this to happen twice on the worksheet. I can't figure out how to change/add to it. I am trying to get it to run the logic for column A and I on my spreadsheet.
Just expand the range you set to the A variable.
Set A = Range("A:A, I:I")
Rewritten as,
Private Sub Worksheet_Change(ByVal Target As Range)
if not intersect(range("A:A, I:I"), target) is nothing then
'add error control
on error goto safe_exit
'don't do anything until you know something has to be done
dim r as range
Application.EnableEvents = False
For Each r In intersect(range("A:A, I:I"), target)
r.Offset(0, 1).Value = Date 'do you want Date or Now?
Next r
end if
safe_exit:
Application.EnableEvents = True
End Sub
edited after OP's comment
expanding on #Jeeped solution, you can avoid looping:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Intersect(Range("A:A, I:I"), Target) ' define range of interest
If Not rng Is Nothing Then ' check it's not "nothing"
If WorksheetFunction.CountA(rng) = rng.Count Then 'check for all of its cells being not empty
On Error GoTo safe_exit 'add error control
Application.EnableEvents = False 'don't do anything until you know something has to be done
rng.Offset(, 1).Value = Date 'write Date next to all relevant changed cells
End If
End If
safe_exit:
Application.EnableEvents = True
End Sub
I currently have a loop that works great to hide columns based on multiple dropdown cells. I would also like to add code to hide sheets based on the same drop downs, but I'm not sure how to add on to my For Each Cell In Range to accommodate that. I have pasted what I have to hide the columns below. Any help would be greatly appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
For Each cell In Range("$A$30:$A$38")
If cell = "Descriptor 1" Or cell = "Descriptor 2" Then
Columns("B:F").EntireColumn.Hidden = False
Exit For
Else
Columns("B:F").EntireColumn.Hidden = True
End If
Next Cell
You can use something like Worksheets("sheet_to_hide").Visible = xlSheetHidden to hide a sheet and Worksheets("sheet_to_unhide").Visible = xlSheetVisible to unhide it again.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim HideIt As Boolean
HideIt = True
For Each cell In Range("$A$30:$A$38")
If cell.Value = "Descriptor 1" Or _
cell.Value = "Descriptor 2" Then
HideIt = False
Exit For
End If
Next Cell
If HideIt Then
Columns("B:F").Hidden = True
Worksheets("Sheet1").Visible = xlSheetHidden
Worksheets("Sheet2").Visible = xlSheetHidden
Else
Columns("B:F").Hidden = False
Worksheets("Sheet1").Visible = xlSheetVisible
Worksheets("Sheet2").Visible = xlSheetVisible
End If
End Sub
If the worksheets are to be hidden / made visible depending on whether their sheet name appears in your range, then I would suggest the following modification:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim HideIt As Boolean
'Don't do anything if there was no change to A30:A38
If Intersect(Target, Range("$A$30:$A$38")) Is Nothing Then Exit Sub
HideIt = True
For Each cell In Range("$A$30:$A$38")
If cell.Value = "Descriptor 1" Or _
cell.Value = "Descriptor 2" Then
HideIt = False
Exit For
End If
Next cell
Columns("B:F").Hidden = HideIt
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name <> ActiveSheet.Name Then
'See if sheet name exists in A30:A38
'Hide the sheet if doesn't, make it visible if it does
ws.Visible = Not IsError(Application.Match(ws.Name, Range("$A$30:$A$38"), 0))
End If
Next
End Sub
#YowE3K Your code is great. But I had a problem with the tab names being in short form and my descriptors being in full form. So, I took your original code, added a "HideTab" for each tab, and switched the topline HideTab = False to true and reversed it in the 4th line HideTab (See below). I'm sure there is a faster way, but this worked like a charm. Thank you very much for your help! You pointed me in the right direction.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim HideIt As Boolean
HideIt = True
For Each cell In Range("$A$30:$A$38")
If cell.Value = "Descriptor 1" Or
cell.Value = "Descriptor 2" Then
HideIt = False
Exit For
End If
Next Cell
Columns("B:F").EntireColumn.Hidden = True
Dim HideTab1 As Boolean
HideTab1 = False
For Each cell In Range("$A$30:$A$38")
If cell = "Descriptor1" Then
HideTab1 = True
Exit For
End If
Next cell
Sheets("Desc1").Visible = HideTab1
Dim HideTab2 As Boolean
HideTab2 = False
For Each cell In Range("$A$30:$A$38")
If cell = "Descriptor2" Then
HideTab2 = True
Exit For
End If
Next cell
Sheets("Desc2").Visible = HideTab2
Dim HideTab3 As Boolean
HideTab3 = False
For Each cell In Range("$A$30:$A$38")
If cell = "Descriptor3" Then
HideTab3 = True
Exit For
End If
Next cell
Sheets("Desc3").Visible = HideTab3
End Sub
I'm setting a Worksheet_Change Macro so that if the contents of Cell K4 are not equal to "Event Based" the contents of J5:K7 are cleared. This works great. Code below.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MRange As Range
Set MRange = Range("K4")
If MRange <> "Event Based" Then
If Union(Target, MRange).Address = MRange.Address Then
Application.EnableEvents = False
Range("J5:K7").Select
Selection.ClearContents
Application.EnableEvents = True
End If
End If
End Sub
But I want a Worksheet_Change event if contents of cell J12 are cleared. But the below macro does NOT work. I know it is to do with cell value being empty, but I would appreciate any help.
Dim NRange As Range
Set NRange = Range("J12")
If NRange = "" Then
If Union(Target, NRange).Address = NRange.Address Then
Application.EnableEvents = False
Range("J5:K7").Select
Selection.ClearContents
Application.EnableEvents = True
End If
End If
End Sub
The code below checks if Cell J12 value has changed, if cell's value is "" then it clears the content of Range "J5:K7".
Private Sub Worksheet_Change(ByVal Target As Range)
Dim IntersectRange As Range
Dim NRange As Range
Set NRange = Range("J12")
Set IntersectRange = Intersect(Target, NRange)
' continue running this code only if Cell J12 has changed
If Not IntersectRange Is Nothing Then
If Target.Value = "" Then
Application.EnableEvents = False
Range("J5:K7").ClearContents
Application.EnableEvents = True
End If
End If
End Sub
I am using the SHEETOFFSET VBA code
Function SHEETOFFSET(offset, Ref)
' Returns cell contents at Ref, in sheet offset
Application.Volatile
With Application.Caller.Parent
SHEETOFFSET = .Parent.Sheets(.Index + offset) _
.Range(Ref.Address).Value
End With
End Function
And then the following code within within my new sheet
=sheetoffset(-1, B2)
to copy the value of cell B2 in the previous sheet to my new sheet.
However, I also need to copy the color of that particular cell. Is there any code that I can enter in the original VBA code above to do this? Or is there another way of achieving this?
Many thanks for your help
Tim
Logic:
Define a Public variable to hold the color of the cell
In Worksheet_Change check if the above variable has any value. If yes then change the color of the target cell.
Once the above is done, reset the variable to 0
Code in Module:
Public cellColor As Double
Function SHEETOFFSET(offset, Ref)
With Application.Caller.Parent
SHEETOFFSET = .Parent.Sheets(.Index + offset) _
.Range(Ref.Address).Value
'~~> Store the color in a variable
cellColor = .Parent.Sheets(.Index + offset) _
.Range(Ref.Address).Interior.ColorIndex
End With
End Function
Code in Sheet Code Area:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aCell As Range
On Error GoTo Whoa
Application.EnableEvents = False
For Each aCell In Target.Cells
If cellColor <> 0 Then aCell.Interior.ColorIndex = cellColor
Next
Letscontinue:
cellColor = 0
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
ScreenShot:
My Personal Thoughts:
I am not in favor of the SHEETOFFSET function in the first place because the formula is actually referring a cell in the current sheet. Any changes, for example, deletion of that cell will error out your formula
It is better to link the cells directly
FOLLOWUP (From Comments)
You can run this code in the end to refresh all formulas.
Sub Sample()
Dim ws As Worksheet
Dim rng As Range, aCell As Range
For Each ws In ThisWorkbook.Sheets
Set rng = Nothing
On Error Resume Next
Set rng = ws.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not rng Is Nothing Then
For Each aCell In rng
aCell.Formula = aCell.Formula
Next
End If
Next
End Sub