Force the user to select only one specific cell - vba

I cannot lock my sheet because I need to access some cells to run macros.
I want a macro that selects cell (F1) whenever the user try to select any other cell.
I need a macro like this one, I guess:
Private Sub Worksheet_Change(ByVal Target As Range)
End Sub

Put this code in the worksheet module:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call Cells(1, 6).Select
End Sub

Like other guys wrote, is better to unprotect the sheet, play your macro and protect the sheet but, if you think that disable all cells, minus the cell that you identify, is the best way, you can use this code:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("F10")) Is Nothing Then 'use your free cell
do
Else
Application.Undo
MsgBox "you can modify only the cell(F10)" 'Just to inform what is the cell editable
Range("F10").Select
End If
Application.EnableEvents = True
End Sub

Here are 2 options:
.
1. Without protecting the sheet - in each sheet module to customize "unlocked" cell (Ex. "C3")
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
With Target
If .Column <> 3 Or .Row <> 3 Or .CountLarge > 1 Then Application.Undo
End With
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
With Target
If .Column <> 3 Or .Row <> 3 Or .CountLarge > 1 Then Cells(3, 3).Select
End With
Application.EnableEvents = True
End Sub
.
2. Protecting the sheet - in ThisWorkbook module
Private Sub Workbook_Open()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
protectWS ws
Next
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
protectWS Sh
End Sub
Public Function protectWS(Optional ByRef ws As Worksheet = Nothing) As Boolean
If ws Is Nothing Then Set ws = Application.ActiveSheet
If Not isWSProtected(ws) Then
ws.Protect Password:=vbNullString, _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, _
UserInterfaceOnly:=True, _
AllowFormattingCells:=False, _
AllowFormattingColumns:=False, _
AllowFormattingRows:=False, _
AllowInsertingColumns:=False, _
AllowInsertingRows:=False, _
AllowInsertingHyperlinks:=False, _
AllowDeletingColumns:=False, _
AllowDeletingRows:=False, _
AllowSorting:=False, _
AllowFiltering:=False, _
AllowUsingPivotTables:=False
End If
End Function
Private Function isWSProtected(Optional ByRef ws As Worksheet = Nothing) As Boolean
isWSProtected = ws.ProtectContents Or _
ws.ProtectDrawingObjects Or _
ws.ProtectScenarios
End Function
Option 1 forces users to cell C3
can be moved to ThisWorkbook module, with parameters for row and column
Option 2 is using an empty password, and allows VBA execution (UserInterfaceOnly)

Related

combobox1_keydown errors when adding duplicate sheet names

In VBA I have a combobox code that will add a new formatted sheet. My problem is it errors when I entered an existing name of sheet. I need a code that shows a msgbox "sheet name already used" if a user entered a existing name of sheet.
Here is my code..
Private Sub combobox1_KeyDown(ByVal KeyCode As_ MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then
Dim wrksht1 As Worksheet, a As String
a = ComboBox1.Value
Set wrksht1 = ActiveWorkbook.Worksheets("FORMAT")
Sheets.ADD after:= Sheets(Sheets.Count)
ActiveSheet.Name = a
wrksht1.Cells.Copy
With ActiveWorkbook.Sheets(a).Cells
.PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
End With
End Sub
you could use a helper function:
Function IsSheetAlreadyThere(shtName As String)
On Error Resume Next
IsSheetAlreadyThere = Not Sheets(shtName) Is Nothing
End Function
and exploit it in your sub:
Private Sub combobox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then
Dim a As String
a = ComboBox1.Value
If IsSheetAlreadyThere(a) Then
MsgBox a & "is the name of an already existing sheet"
Else
Dim wrksht1 As Worksheet
Set wrksht1 = ActiveWorkbook.Worksheets("FORMAT")
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = a
wrksht1.Cells.Copy
With ActiveWorkbook.Sheets(a).Cells
.PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
End With
End If
End If
End Sub

VBA code to work on ALL workbooks

I have this code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Lastrow = ActiveSheet.Cells(Rows.Count, 12).End(xlUp).Row
If ActiveWorkbook.Name Like "FR_*" And WorksheetFunction.CountIf(ActiveSheet.Range(Cells(4, 12), Cells(Lastrow, 12)), "<>Pending Distribution") > 0 Then
MsgBox "Warning, column L has values other than Pending Distribution"
Cancel = True
End If
End Sub
It works when it is saved into the Workbook in vba but it doesn't work in Personal.xlsb
I want to make it work on ALL workbook that start with FR_ , but it is not working despite I am using ActiveSheet and ActiveWorkbook, why ?
using the personal like this should help
Public WithEvents CUSTOM_EXCEL As Excel.Application
Private Sub CUSTOM_EXCEL_WorkbookBeforeSave(ByVal Wb As Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean)
Lastrow = Wb.ActiveSheet.Cells(Rows.Count, 12).End(xlUp).Row
If Wb.Name Like "FR_*" And WorksheetFunction.CountIf(Wb.ActiveSheet.Range(Cells(4, 12), _
Cells(Lastrow, 12)), "<>Pending Distribution") > 0 Then
MsgBox "Warning, column L has values other than Pending Distribution"
Cancel = True
End If
End Sub
Private Sub Workbook_Open()
Set CUSTOM_EXCEL = Application
End Sub

How to remain a code active after all macros have been executed

I have written multiple macros that will be executed with a command button however I want my last macro to remain active after all before macros have been executed. I want Macro15 to remain active after. And for for Macro15 I want if any cell changes I want to highlight that cell with colorindex 3
Sub RunallMacros()
macro1
macro2
macro3
macro5
Macro12
Macro13
Macro14
Macro15
End Sub
Sub macro1()
ThisWorkbook.Sheets("Main").Activate
End Sub
Sub macro2()
Dim myvalue As Variant
myvalue = InputBox("Enter Safety Stock Days")
Range("R5").value = myvalue
End Sub
Sub macro5()
Dim answer As Integer
answer = MsgBox("Are There Any ICF Forms?", vbYesNo + vbQuestion, "Other Sales")
If answer = vbYes Then ICFUserForm.Show
End Sub
Sub macro3()
Dim MyAnswer1 As Variant
Dim MyAnswer2 As Variant
Dim MyAnswer3 As Variant
Dim MyAnswer4 As Variant
Dim MyAnswer5 As Variant
MyAnswer1 = InputBox("Enter Growth Current Month")
Range("m3").value = MyAnswer1
MyAnswer2 = InputBox("Enter Growth Current Month+1")
Range("n3").value = MyAnswer2
MyAnswer3 = InputBox("Enter Growth Current Month+2")
Range("o3").value = MyAnswer3
MyAnswer4 = InputBox("Enter Growth Current Month+3")
Range("p3").value = MyAnswer4
MyAnswer5 = InputBox("Enter Growth Current Month+4")
Range("q3").value = MyAnswer5
End Sub
Sub Macro12()
ActiveCell.FormulaR1C1 = "='raw data'!R[-5]C"
Range("A7").Select
Selection.AutoFill Destination:=Range("A7:A500"), Type:=xlFillDefault
End Sub
Sub Macro13()
Range("C7").Select
Selection.ClearContents
End Sub
Sub Macro14()
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Raw" And ws.Name <> "Main" And ws.Name <> "Calendar" Then
For Each c In ws.Range("A50:A300")
ws.Rows(c.Row).Hidden = c.value = 0
Next
End If
Next
End Sub
Sub Macro15()
If Not Intersect(Target, Range("A7:AH500")) Is Nothing Or _
Not Intersect(Target, Range("A7:AH500")) Is Nothing Then
Target.Interior.ColorIndex = 3
End If
End Sub
A macro that is "active" is doing something, i.e. it is executing code. While it is executing code, the user can't do anything. So either the macro is active or the user is active.
What you want is to respond to an event, in this case the Worksheet.Change event:
Private Sub Worksheet_Change(ByVal Target as Range)
Target.Interior.ColorIndex = 3
End Sub
See https://msdn.microsoft.com/en-us/library/office/ff839775.aspx
Great answer from Paul - try this to get it working;
Private Sub Worksheet_Change(ByVal Sh As Object, ByVal Target as Range)
Target.Interior.ColorIndex = 3
End Sub

Can I have more than one event code under "this Workbook"

I have these 2 codes:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Application.ScreenUpdating = False
For Each Value In Target.Columns
Columns(Value.Column).ColumnWidth = 8.43
Worksheets(Sh.Name).Columns(Value.Column).AutoFit
Next Value
Application.ScreenUpdating = True
End Sub
and
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Application.EnableEvents = False
If Not Target.Cells.Count = 1 Or Target.Row = 1 Then Exit Sub
If Target.Offset(1, 0) = "" Then
Target.Offset(-1, 0).Copy
Target.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End If
Application.EnableEvents = True
End Sub
This two pieces of code work fine but the thing is I can't make them work together these 2 codes should be place under "This Workbook" object in excel so I've been trying to come up with a way for this to work I do understand that you should only have one event code in a workbook but that there is a "workaround" it someone suggested the following:
Private Sub Worksheet_Change(ByVal Target As Range)
Call Macro1(Target)
Call Macro2(Target)
End Sub
Sub Macro1(ByVal Target As Range)
If Target.Column = 1 And Target.Offset(1, 0) = "" Then
Target.Offset(-1, 0).Copy
Target.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End If
End Sub
Sub Macro2(ByVal Target As Range)
Application.ScreenUpdating = False
For Each Value In Target.Columns
Columns(Value.Column).ColumnWidth = 8.43
Worksheets(Sh.Name).Columns(Value.Column).AutoFit
Next Value
Application.ScreenUpdating = True
End Sub
But it does not work none of the event are triggered so as I type nothing happens, I thought at first it would be impossible but when someone suggested this at first it made sense but it doesn't work but still I saw a shred of hope which I want to hang on tight to but since I don't know who to make it work.
Is it possible to have these 2 codes working on the same workbook?
These events need to be under the Sheet object, not the workbook. Note that from the dropdown, when you are in the "thisWorkbook" code section, there is no "Change" event. You'll also need to name the function Private Sub Worksheet_Change(ByVal Target As Range)
So far I've tried this and for now its working
Private Sub Worksheet_Change(ByVal Target As Range)
Call Macro1(Target)
Call Macro2(Target)
End Sub
Sub Macro1(ByVal Target As Range)
Application.EnableEvents = False
If Not Target.Cells.Count = 1 Or Target.Row = 1 Then Exit Sub
If Target.Offset(1, 0) = "" Then
Target.Offset(-1, 0).Copy
Target.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End If
Application.EnableEvents = True
End Sub
Sub Macro2(ByVal Target As Range)
Application.ScreenUpdating = False
For Each Value In Target.Columns
Columns(Value.Column).ColumnWidth = 8.43
ActiveSheet.Columns(Value.Column).AutoFit
Next Value
Application.ScreenUpdating = True
End Sub

Apply a protected sheet macro to all sheets in workbook

I have a macro that opens automatically and applies a special sheet protection which allows for grouping and some editing for a specific sheet, Program Data. The macro I have is this:
Private Sub Workbook_Open()
With Worksheets("Program Data")
.EnableOutlining = True
.Protect UserInterfaceOnly:=True, AllowFiltering:=True, AllowFormattingColumns:=True,
AllowInsertingRows:=True
End With
End Sub
Right now this runs as soon as you open the file, but it only applies to Program Data. I don't know how to change the with statement to accommodate the entire workbook without naming the sheets one-by-one. But there are very many sheets, so that's not a good option. How do I do apply this for all sheets in the file?
You can loop through the worksheet objects like this.
Private Sub Workbook_Open()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
With ws
.EnableOutlining = True
.Protect UserInterfaceOnly:=True, AllowFiltering:=True, _
AllowFormattingColumns:=True, AllowInsertingRows:=True
End With
Next
End Sub
You want a For loop that targets all the sheets. Basically...
Private Sub Workbook_Open()
Dim WS As Worksheet
For Each WS in ThisWorkbook.Worksheets
With WS
.EnableOutlining = True
.Protect UserInterfaceOnly:=True, AllowFiltering:=True, AllowFormattingColumns:=True,
AllowInsertingRows:=True
End With
Next WS
End Sub
Let us know if this helps.
try this
For i = 1 To Worksheets.Count - 1
With Worksheets(i)
.EnableOutlining = True
.Protect UserInterfaceOnly:=True, AllowFiltering:=True, AllowFormattingColumns:=True, AllowInsertingRows:=True
End With
Next