So I have a dynamically created worksheet (generated by clicking a command button on a separate sheet) and I am trying to get a Worksheet_Change event to fire only on a specific range in that worksheet. My code is as follows:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sh As Worksheet
Set sh = ThisWorkbook.ActiveSheet
If Not Intersect(Target, Range("A1:K10")) Is Nothing Then
If sh.Name Like "*SP Temp*" Then
Dim i As Variant, countOfS As Integer
countOfS = 0
For Each i In sh.Range("A1:K10")
If i.Value = "S" Then
countOfS = countOfS + 1
End If
Next i
sh.Range("D12").Value = countOfS
sh.Range("D13").Value = SCount - countOfS
' NOTE: SCount is a global variable set in another Sub
End If
End If
End Sub
The intent is to keep a running count of the number of "S" characters entered into cells in the range A1:K10. I have tried adding in Debug.Print statements after the If Not Intersect... statement, but it doesn't seem to fire, despite the values in the target range being altered. What am I doing wrong?
A Workbook SheetChange: Count and Write
ThisWorkbook Module
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
' Invalidate.
If Not Sh.Name Like "*SP Temp*" Then Exit Sub ' wrong worksheet
Dim rg As Range: Set rg = Sh.Range("A1:K10")
If Intersect(rg, Target) Is Nothing Then Exit Sub ' no intersection
' Count.
Dim CountOfS As Long: CountOfS = Application.CountIf(rg, "s")
' Write
' Disable events to not re-trigger the event while writing
' since the same worksheet is being written to.
Application.EnableEvents = False
Sh.Range("D12").Value = CountOfS
Sh.Range("D13").Value = SCount - CountOfS
Application.EnableEvents = True
End Sub
Related
I am working on a project to clean up a couple hundred excel sheets for an specific import spec. The import process errors out if any rows have a specific value blank, so I'm looking to find the best way to delete all rows in the entire workbook if column C in that row is empty. I found this simple VBA code that works on the active sheet, but I need it to loop through all sheets in the workbook. Any suggestions on a better process so I don't have to run it >100 times?
Sub DelBlankRows()
Columns("C:C").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
End Sub
Delete the Rows of a Column's Blanks
Option Explicit
Sub DelRowsOfColumnBlanksTEST()
Const wsCol As Variant = "C" ' or 3
'Const wsCol As String = "C"
'Const wsCol As Long = 3
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Application.ScreenUpdating = False
Dim ws As Worksheet
For Each ws In wb.Worksheets
DelRowsOfColumnBlanks ws, wsCol
Next ws
Application.ScreenUpdating = True
End Sub
Sub DelRowsOfColumnBlanks( _
ByVal ws As Worksheet, _
ByVal WorksheetColumnID As Variant)
If ws Is Nothing Then Exit Sub ' no worksheet
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
Dim urg As Range: Set urg = ws.UsedRange
If urg.Rows.Count = 1 Then Exit Sub ' only one row
On Error Resume Next
Dim crg As Range: Set crg = ws.Columns(WorksheetColumnID)
On Error GoTo 0
If crg Is Nothing Then Exit Sub ' invalid Worksheet Column ID
Dim tcrg As Range: Set tcrg = Intersect(urg, crg)
' ... is only the same as 'Set tcrg = urg.Columns(WorkhseetColumnID)',...
' ... if the first column of the used range is column 'A'.
If tcrg Is Nothing Then Exit Sub ' no intersection
Dim drg As Range: Set drg = tcrg.Resize(tcrg.Rows.Count - 1).Offset(1)
tcrg.AutoFilter 1, "=" ' ... covers blanks: 'Empty', "=""""", "'"... etc.
' Note that although it contains the word 'Blanks',...
' ... 'SpecialCells(xlCellTypeBlanks)' only covers 'Empty'.
On Error Resume Next
Dim spcrg As Range: Set spcrg = drg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not spcrg Is Nothing Then
spcrg.EntireRow.Delete
'Else
' no 'visible' cells (to delete)
End If
ws.AutoFilterMode = False
End Sub
Option Explicit
Sub CleanWorkbook()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
DeleteRowsOfEmptyColumn sh, "C"
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub DeleteRowsOfEmptyColumn(sh As Worksheet, col as string)
Dim rowsToDelete As New Collection
Dim cell
For Each cell In Intersect(sh.UsedRange, sh.Columns(col))
If cell.Value = "" Then
rowsToDelete.Add cell.Row
End If
Next
Dim i As Integer
For i = rowsToDelete.Count To 1 Step -1
sh.Rows(rowsToDelete(i)).Delete
Next
End Sub
I've put a very basic error trap for any sheets with no values in C. You may need to improve this yourself.
Edit: Updated error trap
Sub DelBlankRows()
Dim sh As Worksheet
Application.ScreenUpdating = False
On Error GoTo Handle
For Each sh In ThisWorkbook.Worksheets
sh.Activate
Columns("C:C").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
Cont:
Next sh
Application.ScreenUpdating = True
Exit Sub
Handle:
If Err.Number = 1004 Then Resume Cont
End Sub
I found this code below to help combine multiple sheets of data into one, however, it won't take from multiple sheets. I have two sheets and it either grabs one or the other. I tried to add on to it to specify more than one sheet but that doesn't seem to work either. How can I make this pull from multiple sheets? I have a sheet "anaheim" and sheet "Woodridge."
Sub Step3()
Dim i As Long
Dim xRg As Range
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "MasterSheet"
For i = 2 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If i > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
Sheets(i).Activate
ActiveSheet.UsedRange.Copy xRg
Next
End Sub
Sub Step3()
Dim sh As Worksheet
Dim xRg As Range
Sheets.Add.Name = "MasterSheet"
For Each sh In Sheets
If sh.Name <> "MasterSheet" Then
sh.UsedRange.Copy Sheets("MasterSheet").Cells(Sheets("MasterSheet").Rows.Count, "A").End(xlUp).Offset(1)
End If
Next
End Sub
Backup Used Ranges
Option Explicit
Sub backupUsedRanges()
' Target Worksheet
Const tgtSheetName As String = "MasterSheet"
Const tgtFirstCell As String = "A1"
' Workbook
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Check if a sheet named 'tgtSheetName' already exists.
Dim Msg As Variant
If SheetExists(wb, tgtSheetName) Then
Msg = MsgBox("A sheet named '" & tgtSheetName _
& "' already exists. Do you want to delete it?", _
vbYesNo + vbExclamation, "Delete?")
If Msg = vbYes Then
Application.DisplayAlerts = False
wb.Worksheets(tgtSheetName).Delete
Application.DisplayAlerts = True
Else
MsgBox "Backup NOT created.", vbExclamation, "Fail"
Exit Sub
End If
End If
' Define (add) Target Worksheet ('tgt').
Dim tgt As Worksheet
Set tgt = wb.Worksheets.Add(Before:=wb.Sheets(1))
tgt.Name = tgtSheetName
' Define Next Target First Available Cell Range ('cel').
Dim cel As Range
Set cel = tgt.Range(tgtFirstCell)
' Write from Source Worksheets ('src') to Target Worksheet.
Dim src As Worksheet ' Current Source Worksheet
Dim rng As Range ' Current Source Used Range
For Each src In wb.Worksheets
If StrComp(src.Name, tgtSheetName, vbTextCompare) <> 0 Then
' Define Current Source Used Range ('rng').
Set rng = src.UsedRange
' Copy Current Source Used Range to Target Worksheet.
rng.Copy cel
' Define Next Target First Available Cell Range.
Set cel = cel.Offset(rng.Rows.Count)
End If
Next src
' Inform user
MsgBox "Backup created.", vbInformation, "Success"
End Sub
Function SheetExists(Book As Workbook, SheetName As String) As Boolean
Dim sh As Object
For Each sh In Book.Sheets
If StrComp(sh.Name, SheetName, vbTextCompare) = 0 Then
SheetExists = True
Exit Function
End If
Next sh
End Function
I'm looking for a way to write into another sheet in excel, every time someone either protects or unprotects the sheet in my Workbook. I want it to log whether it was protected or unprotected and the time beside it. Thanks!
Right now I have the following code for protecting or unprotecting the sheet with a more user friendly button:
If ActiveWorkbook.Sheets("Calendar").ProtectContents = True Then
ActiveSheet.Unprotect
MsgBox "Sheet unprotected"
Exit Sub
End If
ActiveSheet.Protect ("password")
MsgBox "Calendar has been protected"
Excel VBA does not have an event that can detect if a sheet is being protected/unprotected.
Don't shoot the messenger.
A google would have landed you here: https://www.ozgrid.com/forum/index.php?thread/43816-unprotect-worksheet-event/, the author even gives you a sample:
https://www.ozgrid.com/forum/core/index.php?attachment/1082834-52719-xls/
This is not 100% fool proof as the eventhandler can not tell when a user Cancels the protect/unprotect dialog.
This workbook
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
StartEventListiner False
End Sub
Private Sub Workbook_Open()
StartEventListiner True
End Sub
Module
Option Explicit
Public g_clsEvnt As CProtectEvt
Public Sub StartEventListiner(Action As Boolean)
If Action Then
Set g_clsEvnt = New CProtectEvt
Else
Set g_clsEvnt = Nothing
End If
End Sub
Class
Option Explicit
Public WithEvents cbbProtect As CommandBarButton
Private Sub m_ProtectControls(State As Boolean)
Dim objX As OLEObject
On Error Resume Next
For Each objX In ActiveSheet.OLEObjects
objX.Object.Enabled = State
Next
End Sub
Private Sub cbbProtect_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
m_ProtectControls (InStr(1, Ctrl.Caption, "Un&protect", vbTextCompare) > 0)
End Sub
Private Sub Class_Initialize()
On Error Resume Next
' hook into Tools > Protection > Protect Sheet event
Set cbbProtect = Application.CommandBars.FindControl(msoControlButton, ID:=893)
End Sub
Toggle and Log Worksheet Protection
The code only logs the protection when using the button (which has toggleWorksheetProtection_Click assigned to it) or when running toggleWorksheetProtection_Click from VBE.
Copy the complete code into a standard module (e.g. Module11).
Adjust the values of the five constants.
ThisWorkbook refers to the workbook containing this code.
Additionally adjust the date format in writeLogRow.
The Code
Option Explicit
Sub toggleWorksheetProtection_Click()
' Constants
Const srcName As String = "Calendar"
Const tgtName As String = "Log"
Const tgtCol As Variant = 1
Const msgProtect As String = "Sheet protected."
Const msgUnProtect As String = "Sheet unprotected."
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
' Other Variables
Dim src As Worksheet: Set src = wb.Worksheets(srcName)
Dim tgt As Worksheet: Set tgt = wb.Worksheets(tgtName)
Dim msg As String
' Protection
If src.ProtectContents Then
src.Unprotect: msg = msgUnProtect
Else
src.Protect: msg = msgProtect
End If
' Log
Dim cel As Range
Set cel = getEmptyCell(tgt, tgtCol)
writeLogRow cel, msg
End Sub
Function getEmptyCell(Sheet As Worksheet, ByVal writeColumn As Variant)
Dim cel As Range
Set cel = Sheet.Columns(writeColumn).Find("*", , xlValues, , , xlPrevious)
If Not cel Is Nothing Then
Set cel = cel.Offset(1)
Else
Set cel = Sheet.Cells(1, writeColumn)
End If
Set getEmptyCell = cel
End Function
Sub writeLogRow(logRange As Range, ByVal logMessage As String)
Dim logDate As Date: logDate = Now
logRange.Value = logDate
logRange.NumberFormat = "mm/dd/yyyy hh:mm:ss (ddd)"
logRange.Offset(, 1).Value = logMessage
End Sub
I'm trying to finish this off so that I can click on cells ws2(D11) and ws3(C12) and show a box containing the ClientNumber. I just can't get my head around how that works, as I've tried to adapt some solutions to my code, but have been unsuccessful, and don't know quite why.
Public ClientNumber As String
Sub Booker()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Set ws = Sheets("ClientEnd")
Set ws2 = Sheets("Booking End")
Set ws3 = Sheets("Training End")
Dim ClientName As String
ClientName = InputBox("Please enter your name")
ClientNumber = InputBox("Please enter a contact number")
ws2.Range("D11") = ClientName
ws3.Range("C12") = ClientName
ws2.Range("O11:R11").Style = "Good"
ws3.Range("H12:K12").Style = "Good"
ws3.Range("I12").Style = "Normal"
Call NumberBox
End Sub
Sub NumberBox()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Set ws = Sheets("ClientEnd")
Set ws2 = Sheets("Booking End")
Set ws3 = Sheets("Training End")
If Target.Address = ws2.Range("$D$11") Then MsgBox ClientNumber
If Target.Address = ws3.Range("$C$12") Then MsgBox ClientNumber
End Sub
I was hoping to have the ClientNumber pop up in a message when I clicked on the given cells in each sheet, which do update to the ClientName successfully, but nothing happens. No errors, nothing.
You can use the event Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean).
In ws3 put
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("C12")) Is Nothing Then 'range than u want to capture
Call NumberBox 'your code
End If
End Sub
Do the same for ws2
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("D11")) Is Nothing Then 'range than u want to capture
Call NumberBox 'your code
End If
End Sub
You have to double click on the cell to run the event
You could try adding the SelectionChange event to the worksheets. On Worksheet 2 and 3 Add the code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "&D&11" Then 'Change the "&D&11" to "&C&12" for worksheet 3
Call NumberBox ' You could also add Target as a paramater
End If
End Sub
I am developing code which creates a copy of a template spreadsheet whenever text is input into any row within column A. The spreadsheet needs to be named after the text entered.
Currently I have the following code, the problem is that it does not name the new spreadsheet after the text I enter.
The code is as below:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsNew As Worksheet
If Target.Cells.Count > 1 Then Exit Sub
On Error Resume Next
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
Set wsNew = Sheets(Target.Text)
If wsNew Is Nothing Then
Worksheets("Template").Copy After:=Worksheets(Worksheets.Count)
End If
'name new sheet code here
End If
End Sub
Like this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsNew As Worksheet
If Target.Cells.Count > 1 Then Exit Sub
On Error Resume Next
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
Set wsNew = Sheets(Target.Text)
If wsNew Is Nothing Then
Worksheets("Template").Copy After:=Worksheets(Worksheets.Count)
End If
'name new sheet
Worksheets(Worksheets.Count).Name = Target.Text
End If
End Sub
Edit:
User could empty the cell in A1:A10 which will create new tab called "Template (2)". You should also do check:
If Len(Target.Cells.Text) = 0 Then Exit Sub
I'd suggest something like this to create the sheet based on the template with the desired name - but after testing and cleansing the proposed sheet name first for invalid characters
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsNew As Worksheet
Dim strSht As String
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
On Error Resume Next
Set wsNew = Sheets(Target.Text)
On Error GoTo 0
If wsNew Is Nothing Then
If ValidSheetName(Target.Value) Then
strSht = Target.Value
Else
strSht = CleanSheetName(Target.Value)
End If
End If
Worksheets("Template").Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = strSht
End If
End Sub
string cleaning code 1
Function ValidSheetName(strIn As String) As Boolean
Dim objRegex As Object
Set objRegex = CreateObject("vbscript.regexp")
objRegex.Pattern = "[\<\>\*\\\/\?|]"
ValidSheetName = Not objRegex.test(strIn)
End Function
string cleaning code 2
Function CleanSheetName(strIn As String) As String
Dim objRegex As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = "[\<\>\*\\\/\?|]"
CleanSheetName = .Replace(strIn, "_")
End With
End Function