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
Related
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
Does anyone know any VBA code that will close and save an excel file after a delay? I tried some kutools code that was supposed to close only after some idle time but it closes without checking for inactivity.
Paste in Routine Module:
Option Explicit
Const idleTime = 30 'seconds
Dim Start
Sub StartTimer()
Start = Timer
Do While Timer < Start + idleTime
DoEvents
Loop
'///////////////////////////////////////////////////////
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Step 1: Declare your variables
Dim ws As Worksheet
'Step 2: Unhide the Starting Sheet
Sheets("Sheet1").Visible = xlSheetVisible
'Step 3: Start looping through all worksheets
For Each ws In ThisWorkbook.Worksheets
'Step 4: Check each worksheet name
If ws.Name <> "Sheet1" Then
'Step 5: Hide the sheet
ws.Visible = xlVeryHidden
End If
'Step 6: Loop to next worksheet
Next ws
'Application.ScreenUpdating = True
Range("A1").Select
ThisWorkbook.Save
'Application.DisplayAlerts = True
'//////////////////////////////////////////////////////////
'Application.DisplayAlerts = False
Application.Quit
ActiveWorkbook.Close SaveChanges:=True
Application.DisplayAlerts = True
End Sub
Paste in ThisWorkbook :
Option Explicit
Private Sub Workbook_Open()
StartTimer
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
StartTimer
End Sub
Paste in Routine Module:
Sub Reset()
Static SchedSave
If SchedSave <> 0 Then
Application.OnTime SchedSave, "SaveWork", , False
End If
SchedSave = Now + TimeValue("00:10:00") '<--- Ten minutes
Application.OnTime SchedSave, "SaveWork", , True
End Sub
Sub SaveWork()
MsgBox "Run the close workbook macro here."
'ThisWorkbook.Save
'Application.Quit
'ThisWorkbook.Close
End Sub
Paste in ThisWorkbook:
Private Sub Workbook_Open()
Reset
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Reset
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Reset
End Sub
Timer will start automatically when workbook is opened. Presently set for 10 minutes (can be adjusted). Closing macro code has been disabled and presently replaced with a MsgBox notice.
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
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
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)