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

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

Related

Attempting to step through columns in a search

I am attempting to create a module in Excel 2016 that will scan through a sheet and auto size any comments found. My current code requires me to adjust the Column Letter each time I run it. I am looking for a method to step through the columns in my loop. My current code is listed below and I am thanking anyone ahead of time for any assistance I can get. My current sheet only uses columns A through P.
Sub cmtsize()
ActiveSheet.Unprotect pswd
Range("a7:I7").Select
lrow = Cells(Rows.Count, 1).End(xlUp).Row
For xrow = 7 To lrow
xcell = "c" & lrow
Range(xcell).Select
If ActiveCell.Comment Is Nothing Then
GoTo nxt
Else
With Range(xcell).Comment.Shape
.TextFrame.AutoSize = True
End With
nxt:
End If
Next xrow
ActiveSheet.Protect pswd
Range("A6").Select
MsgBox "Finished!"
End Sub
This will resize all comments on the specified worksheet. [Update] included option for password protected sheets. As well as the Finished Msgbox.
Sub test()
Call ResizeComments(Sheet1)
MsgBox ("Finished!")
End Sub
Private Sub ResizeComments(ByVal ws As Worksheet, Optional ByVal Pass As String = "")
If Pass <> "" Then ws.Unprotect Pass
Dim oComment As Comment
For Each oComment In ws.Comments
oComment.Shape.TextFrame.AutoSize = True
Next
If Pass <> "" Then ws.Protect Pass
End Sub

How can I stop editing cell if it is not done with in set time?

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

How to get VBA code to run on Multiple Sheets?

I was wondering how to get this code to work on every sheet and new sheets that will be made in the Excel workbook. The new sheet Thank you to everyone that helps.
Dim cmt As Comment
Dim charCount As String
Dim prevTarget As Range
Sub Worksheet_C(ByVal Target As Range)
If Target.Value <> Empty Or Target.Value <> "0" Then
If Target.Value <> Empty Then
Set prevTarget = Target
Set Target = Target
End If
Set cmt = prevTarget.Comment
If Target = Empty Then
Set prevTarget = Target
End If
If cmt Is Nothing Then
'MsgBox "There is no comment"
ElseIf Len(cmt.Text) > 150 Then
charCount = Len(cmt.Text)
MsgBox "Character Limit is 150. Your comment contains " + charCount + "."
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call Worksheet_C(Target)
End Sub
The Workbook_SheetSelectionChange() in ThisWorkbook witll execute for all sheets:
In ThisWorkbook module:
Option Explicit
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
RestrictCommentSize Target
End Sub
Module1 (a new generic VBA module) can contain your initial Sub Worksheet_C (cleaned up a bit)
Option Explicit
Public Sub RestrictCommentSize(ByVal Target As Range)
With Target
If .CountLarge = 1 Then
If Len(.Value2) <> 0 And .Value2 <> "0" And Not .Comment Is Nothing Then
If Len(.Comment.Text) > 150 Then
Dim msg As String
msg = "Your comment contains " & Len(.Comment.Text) & " characters"
MsgBox msg & vbCrLf & vbCrLf & "(more than the max of 150)"
End If
End If
End If
End With
End Sub
Worksheet_SelectionChange is a worksheet specific routine.
If new sheets are created manually, you cannot easily control the sheet's VBA content (unless you run a background process to poll the sheets and check if the code exists).
However, if the sheets are created by code, you can add code that will also create the sheet specific VBA code.

Populate ComboBox With Sheet Names Dynamically

I am having trouble with populating a combo box on a excel ribbon dynamically.
I wish for the combo box to be populated using the names of the sheets of the workbook dynamically.
I am able to select the sheet names already presentin the combo box that is placed on the ribbon however I do not seam to be able to code the VBA to populate the combo box with the sheet names if I add them or modify the name.
I have written below code but its not working :
Sub SelectionFeuille_GetItemLabel(control As IRibbonControl, index As Integer, ByRef returnedVal)
Dim dTime As Date
dTime = Now + TimeValue("00:00:01") 'hh:mm:ss
Application.OnTime dTime, "Refresh_all"
returnedVal = ActiveWorkbook.Worksheets(index + 1).Name
End Sub
Please help me....
The simplest way I've found to do this is to capture the Calculate event, and I do that by having a hidden worksheet with formulae to each sheet in its cells. It's far from perfect and, if truth be told, is a pretty ugly workaround, but at least it's food for thought for you. I guess a timer would also work but that seems just as ugly.
All of this code goes in the code behind your workbook:
Option Explicit
Private Const NAMES_SHEET As String = "Hidden|Sheet|Names"
Private mNamesSheet As Worksheet
Private Sub Workbook_Open()
Dim b As Boolean
b = Application.ScreenUpdating
On Error Resume Next
Set mNamesSheet = ThisWorkbook.Worksheets(NAMES_SHEET)
On Error GoTo 0
If mNamesSheet Is Nothing Then
Application.ScreenUpdating = False
Set mNamesSheet = ThisWorkbook.Worksheets.Add
mNamesSheet.Name = NAMES_SHEET
mNamesSheet.Visible = xlSheetVeryHidden
End If
WriteNamesOfSheets
Application.ScreenUpdating = b
End Sub
Private Sub WriteNamesOfSheets()
Dim v() As Variant
Dim ws As Worksheet
Dim i As Integer
Dim b As Boolean
b = Application.EnableEvents
Application.EnableEvents = False
ReDim v(1 To ThisWorkbook.Worksheets.Count, 1 To 1)
mNamesSheet.Cells.Clear
i = 0
For Each ws In ThisWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then
i = i + 1
v(i, 1) = "=" & ws.Name & "!A1"
End If
Next
mNamesSheet.Range("A1").Resize(UBound(v, 1)).Formula = v
Application.EnableEvents = b
End Sub
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Dim ws As Worksheet
Dim b As Boolean
On Error GoTo EH
b = Application.EnableEvents
Application.EnableEvents = False
WriteNamesOfSheets
For Each ws In ThisWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then
'
'Populate your combobox here with ws.Name
'
End If
Next
Application.EnableEvents = b
Exit Sub
EH:
Err.Clear
End Sub

Force the user to select only one specific cell

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)