Following advice from here, Loop through named range list, I have tried to make the following code more efficient with a loop.
Sub Worksheet_Calculate()
Application.EnableEvents = False
Range("in1.1").Rows.EntireRow.Hidden = (Range("in1.1").Cells(1, 1).Value = "No")
Range("in1.2").Rows.EntireRow.Hidden = (Range("in1.2").Cells(1, 1).Value = "No")
Application.EnableEvents = True
End Sub
However, I still get a runtime error of various flavors, and I don't really understand how VBA properties work.
Sub Worksheet_Calculate()
Application.EnableEvents = False
Dim TargetSheetName As String
TargetSheetName = "Input data"
For Each nmdrange In ThisWorkbook.Names
If Range(nmdrange.RefersTo).Parent.Name = TargetSheetName Then
'Loop over benefits
Range(nmdrange).Rows.EntireRow.Hidden = (Range(nmdrange).Cells(1, 1).Value = "No")
End If
Next nmdrange
Application.EnableEvents = True
End Sub
This worked for me:
Sub Worksheet_Calculate()
Dim nmdrange As Name, rng As Range
On Error GoTo haveError
Application.EnableEvents = False
For Each nmdrange In ThisWorkbook.Names
Set rng = Range(nmdrange.RefersTo) '<< set a variable to simplify subsequent code
'you can use Me to refer to the sheet where this code is running
If rng.Parent.Name = Me.Name Then
'Loop over benefits
rng.Rows.EntireRow.Hidden = (rng.Cells(1, 1).Value = "No")
End If
Next nmdrange
haveError:
'## alert if error
If Err.Number <> 0 Then MsgBox "Error" & Err.Description
Application.EnableEvents = True
End Sub
Related
I’m a total newbie at this. I’ve got a worksheet with a list of jobs. One of the columns relate to the location eg, London, Manchester. When London is selected, I want that row copied to the London worksheet, and so on.
Also, I’ve got a column to show when the job is completed. So when I select completed, I want that row cut and pasted into the completed worksheet.
Now, after searching, I’ve found the code for both these actions and individually they work. But I’m trying to get them to work together. I’ve tried multiple things from searches I’ve done on here and google but nothing is working.
These are the codes I’ve got that work individually:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsUse As Worksheet
Dim wsDc As Worksheet
Dim strdc As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column <> 9 Then Exit Sub ' change 2 to the correct column number
Set wsUse = ThisWorkbook.Sheets("Workload Overview")
Set wsDc = ThisWorkbook.Sheets("Completed")
With wsUse
strdc = Target.Value
If strdc = "Completed" Then
n = .Rows.Count
Target.EntireRow.Copy
wsDc.Range("A" & n).End(xlUp).Offset(1, 0).PasteSpecial xlValues
wsDc.Range("A" & n).End(xlUp).EntireRow.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
Target.EntireRow.Delete
End If
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsUse As Worksheet
Dim wsDc As Worksheet
Dim strdc As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column <> 6 Then Exit Sub ' change 2 to the correct column number
Set wsUse = ThisWorkbook.Sheets("Workload Overview")
Set wsDc = ThisWorkbook.Sheets("London")
With wsUse
strdc = Target.Value
If strdc = "London" Then
n = .Rows.Count
Target.EntireRow.Copy
wsDc.Range("A" & n).End(xlUp).Offset(1, 0).PasteSpecial xlValues
wsDc.Range("A" & n).End(xlUp).EntireRow.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
Target.EntireRow.Copy
End If
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Worksheet_Change is an event that Excel looks out for and the code should be in a worksheet module (rather than ThisWorkbook or a normal module).
You can only have one Worksheet_Change change code in a module - shouldn't compile with it twice as you have.
So you need to combine the two procedures into one.
I've made a couple of assumptions - you set wsDC to London. You were then going to add similar code for Manchester and any other city. If you can guarantee your selected cities will be the same as the sheet name then use that to find your sheet to paste to.
If column 9 isn't Completed (could be Cancelled, In Progress) then can exit the sub as well.
The only difference between a Completed record and a City record are that the completed ones are deleted, so that can be treated the same way as cities except the last IF block that checks whether it needs deleting or not.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrorHandler 'Turn on error handling.
'You may not need to turn off calculation or screenupdating.
'Always polite to return it to the setting it was, rather than assuming
'so remember the setting so can be put back later.
Dim CalcMethod As Long
CalcMethod = Application.Calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'This is needed if the row is deleted.
'Deleting a row is a Change event which will cause this code to fire a second time.
Application.EnableEvents = False
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column <> 9 And Target.Column <> 6 Then Exit Sub
If Target.Column = 9 And Target.Value <> "Completed" Then Exit Sub
'Assuming Target value will be the same as the sheet name if column 6,
'or a "Completed" if it's column 9.
'e.g. London, Manchester, New York, Completed.
Dim wsDc As Worksheet
Set wsDc = ThisWorkbook.Worksheets(Target.Value)
Target.EntireRow.Copy
wsDc.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlValues
wsDc.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteFormats
If Target.Column = 9 And Target.Value = "Completed" Then
Application.CutCopyMode = False
Target.EntireRow.Delete xlShiftUp
End If
TidyExit:
'Turn everything back on.
Application.EnableEvents = True
Application.Calculation = CalcMethod
Application.ScreenUpdating = True
Exit Sub
'If an error occurs, skip to this section (which is outside the main body),
'deal with the error and jump back into the code so everything can be
'turned back on before exiting.
ErrorHandler:
MsgBox Err.Number & vbCr & Err.Description, vbOKOnly + vbCritical
Resume TidyExit
End Sub
enter image description hereI have a spreadsheet that has 3 checkbox options for each row, I have created a VBA to disable the other 2 checkboxes once a checkbox is created (so that only 1 checkbox can be checked), however my solution only works for one row and I need some help in rewriting this so that it will apply to all rows please. (I'm new to VBA).
The code I have used is this:
Private Sub CheckBox1_Click()
If CheckBox1.Value = True Then
CheckBox2.Value = False
CheckBox2.Enabled = False
CheckBox3.Value = False
CheckBox3.Enabled = False
Else
CheckBox2.Value = False
CheckBox2.Enabled = True
CheckBox3.Value = False
CheckBox3.Enabled = True
End If
End Sub
Private Sub CheckBox2_Click()
If CheckBox2.Value = True Then
CheckBox1.Value = False
CheckBox1.Enabled = False
CheckBox3.Value = False
CheckBox3.Enabled = False
Else
CheckBox1.Value = False
CheckBox1.Enabled = True
CheckBox3.Value = False
CheckBox3.Enabled = True
End If
End Sub
Private Sub CheckBox3_Click()
If CheckBox3.Value = True Then
CheckBox1.Value = False
CheckBox1.Enabled = False
CheckBox2.Value = False
CheckBox2.Enabled = False
Else
CheckBox1.Value = False
CheckBox1.Enabled = True
CheckBox2.Value = False
CheckBox2.Enabled = True
End If
End Sub
You should probably just use Radios it would be a lot simpler.
If you are intent on doing this you will need to delete all your boxes and then put this code in. It will create and name your boxes and assign them code on click.
Alright, This needs to go in your Sheet module:
Sub Worksheet_Activate()
'Change Module2 to whatever the module name you are using is.
Module2.ActivateCheckBoxes ActiveSheet
End Sub
This next stuff will go into the module you're referencing from the Worksheet Module.
Sub ActivateCheckBoxes(sht As Worksheet)
If sht.CheckBoxes.Count = 0 Then
CreateCheckBoxes sht
End If
Dim cb As CheckBox
For Each cb In sht.CheckBoxes
'You may be able to pass sht as an object, It was giving me grief though
cb.OnAction = "'Module2.CheckBoxClick """ & cb.name & """, """ & sht.name & """'"
Next cb
End Sub
Sub CreateCheckBoxes(sht As Worksheet)
Dim cell As Range
Dim chkbox As CheckBox
With sht
Dim i As Long
Dim prevrow As Long
prevrow = 0
For Each cell In .Range("B2:D5") 'Change this to whatever range you want.
If prevrow < cell.row Then
prevrow = cell.row
i = 0
End If
Set chkbox = .CheckBoxes.Add(cell.Left, cell.Top, 30, 6)
With chkbox
.name = "CheckBox" & i & "_" & cell.row
.Caption = ""
End With
i = i + 1
Next cell
End With
End Sub
Sub CheckBoxClick(chkname As String, sht As String)
Dim cb As CheckBox
With Worksheets(sht)
For Each cb In .CheckBoxes
If Split(cb.name, "_")(1) Like Split(chkname, "_")(1) And Not cb.name Like chkname Then
cb.Value = -4146
End If
Next cb
End With
End Sub
You do not say anything about your sheet check boxes type... Please, test the next solution. It will be able to deal with both sheet check boxes type:
Copy this two Subs in a standard module:
Public Sub CheckUnCheckRow(Optional strName As String)
Dim sh As Worksheet, s As CheckBox, chK As OLEObject ' MSForms.CheckBox
Set sh = ActiveSheet
If strName <> "" Then
Set chK = sh.OLEObjects(strName) '.OLEFormat.Object
solveCheckRow chK.Object.Value, sh, Nothing, chK
Else
Set s = sh.CheckBoxes(Application.Caller)
solveCheckRow s.Value, sh, s
End If
End Sub
Sub solveCheckRow(boolVal As Long, sh As Worksheet, chF As CheckBox, Optional chK As OLEObject)
Dim s As CheckBox, oObj As OLEObject, iCount As Long
If Not chF Is Nothing Then
For Each s In sh.CheckBoxes
If chF.TopLeftCell.Address <> s.TopLeftCell.Address Then
If s.TopLeftCell.Row = chF.TopLeftCell.Row Then
s.Value = IIf(boolVal = -4146, 1, -4146): iCount = iCount + 1
If iCount = 2 Then Exit Sub
End If
End If
Next
ElseIf Not chK Is Nothing Then
For Each oObj In sh.OLEObjects
If oObj.TopLeftCell.Address <> chK.TopLeftCell.Address Then
If oObj.TopLeftCell.Row = chK.TopLeftCell.Row Then
boolStopEvents = True
oObj.Object.Value = IIf(boolVal = 0, True, False): iCount = iCount + 1
boolStopEvents = False
If iCount = 2 Then Exit Sub
End If
End If
Next
End If
End Sub
For case of Form check boxes type:
a). Manually assign the first sub to all your Form Type check boxes (right click - Assign Macro, choose CheckUnCheckRow and press OK).
b). Automatically assign the macro:
Dim sh As Worksheet, s As CheckBox
Set sh = ActiveSheet ' use here your sheet keeping the check boxes
For Each s In sh.CheckBoxes
s.OnAction = "'" & ThisWorkbook.Name & "'!CheckUnCheckRow"
Next
End Sub
If your check boxes have already assigned a macro, adapt CheckUnCheckRow, in Form check boxes section, to also call that macro...
For case of ActiveX check boxes:
a). Create a Public variable on top of a standard module (in the declarations area):
Public boolStopEvents
b). Manually adapt all your ActiveX check boxes Click or Change event, like in the next example:
Private Sub CheckBox1_Click()
If Not boolStopEvents Then CheckUnCheckRow "CheckBox1"
End Sub
Private Sub CheckBox2_Click()
If Not boolStopEvents Then CheckUnCheckRow "CheckBox2"
End Sub
Private Sub CheckBox3_Click()
If Not boolStopEvents Then CheckUnCheckRow "CheckBox3"
End Sub
and so on...
c). Or do all that with a click, using the next piece of code:
Sub createEventsAllActiveXCB()
Dim sh As Worksheet, oObj As OLEObject, strCode As String, ButName As String
Set sh = ActiveSheet 'use here your sheet keeping ActveX check boxes
For Each oObj In sh.OLEObjects
If TypeName(oObj.Object) = "CheckBox" Then
ButName = oObj.Name
strCode = "Private Sub " & ButName & "_Click()" & vbCrLf & _
" If Not boolStopEvents Then CheckUnCheckRow """ & ButName & """" & vbCrLf & _
"End Sub"
addClickEventsActiveXChkB sh, strCode
End If
Next
End Sub
Anyhow, the code cam be simplified in order to deal with only a type of such check boxes. If you intend to use it and looks too bushy, I can adapt it only for the type you like. Like it is, the code deals with both check box types, if both exist on the sheet...
Save the workbook and start playing with the check boxes. But, when you talk about check boxes on a row, all tree of them must have the same TopLeftCell.Row...
I am brand new to coding.
I am trying to use the code to move rows to different sheets and to move completed rows to a different work.
I am having trouble that the Sub Worksheet_Change is being seen as ambiguous name and doesn't work when I try to change the name to something like Worksheet_ChangeCOMPLETE or WorkSheet_Change3.
Below is the codes that I am trying to use.
What my plan is that I want completed orders (rows) to move to a new workbook in which I have named "COMPLETED" when a command button is pushed which triggers a Macro to insert the word "COMPLETE" in column 13 (M).
This new workbook was formerly my sheet 2 but I made it a new workbook following instruction from another forum. I also need rows to move to sheet 3 when "PARTIAL HOLD" inserted in column 13 via a different command button and then returned to sheet one when the command button on sheet 3 "RESUME" is clicked.
All workbooks and worksheets have all the same columns and spacing, I just can't get the codes to work when I rename them.
The first set of codes I am posting are for moving rows from sheet 1 to sheet 3 when the command button is pressed, followed by the code to move rows to the new workbook these codes are in Sheet 1 under VBA project, not a module.
The third is on sheet 3 to move rows back to sheet 1 once HOLD is complete.
Thank you in advance for your help.
SHEET 1
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDest As Range
Set rngDest = Sheet3.Range("A5:R5")
If Not Intersect(Target, Sheet1.Range("M5:M290")) Is Nothing Then
If UCase(Target) = "PARTIAL HOLD" Then
Application.EnableEvents = False
Target.EntireRow.Select
Selection.Cut
rngDest.Insert Shift:=xlDown
Selection.Delete
Application.EnableEvents = True
End If
End If
End Sub
Private Sub Worksheet_ChangeCOMPLETE(ByVal Target As Range)
Dim destWbk As String
Dim wbk As Workbook
Dim rngDestCOMPLETE As Range
destWbk = ThisWorkbook.Names("Completed.xlsx").RefersTo
destWbk = Replace(destWbk, "=" & Chr(34), "")
destWbk = Replace(destWbk, Chr(34), "")
Set wbk = Application.Workbooks(destWbk)
Set rngDest = wbk.Names("A1:S1").RefersToRange
If Not Intersect(Target, Sheet1.Range("rngTrigger")) Is Nothing Then
If UCase(Target) = "COMPLETED" Then
Application.EnableEvents = False
Target.EntireRow.Select
Selection.Cut
rngDest.Insert Shift:=xlDown
Selection.Delete
Application.EnableEvents = True
End If
End If
End Sub
SHEET 3
Private Sub Worksheet_Change3(ByVal Target As Range)
Dim rngDest3 As Range
Set rngDest3 = Sheet1.Range("A5:S5")
If Not Intersect(Target, Sheet3.Range("M5:M290")) Is Nothing Then
If UCase(Target) = "IN PROGRESS" Then
Application.EnableEvents = False
Target.EntireRow.Select
Selection.Cut
rngDest.Insert Shift:=xlDown
Selection.Delete
Application.EnableEvents = True
End If
End If
End Sub
As I mentioned on the comment you cannot rename these Subs, but you can do something like below:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDest As Range, rngDest2 As Range, rngDest3 As Range
Dim destWbk As String
Dim wbk As Workbook
If UCase(Target.Value) = "PARTIAL HOLD" Then
Set rngDest = Sheet3.Range("A5:R5")
If Not Intersect(Target, Sheet1.Range("M5:M290")) Is Nothing Then
Application.EnableEvents = False
Target.EntireRow.Cut
rngDest.Insert Shift:=xlDown
Target.EntireRow.Delete
Application.EnableEvents = True
End If
ElseIf UCase(Target.Value) = "IN PROGRESS" Then
Set rngDest3 = Sheet1.Range("A5:S5")
If Not Intersect(Target, Sheet3.Range("M5:M290")) Is Nothing Then
Application.EnableEvents = False
Target.EntireRow.Cut
rngDest3.Insert Shift:=xlDown
Target.EntireRow.Delete
Application.EnableEvents = True
End If
ElseIf UCase(Target.Value) = "COMPLETED" Then
destWbk = ThisWorkbook.Names("Completed.xlsx").RefersTo
destWbk = Replace(destWbk, "=" & Chr(34), "")
destWbk = Replace(destWbk, Chr(34), "")
Set wbk = Application.Workbooks(destWbk)
Set rngDest2 = wbk.Range("A1:S1")
If Not Intersect(Target, Sheet1.Range("rngTrigger")) Is Nothing Then
Application.EnableEvents = False
Target.EntireRow.Cut
rngDest2.Insert Shift:=xlDown
Target.EntireRow.Delete
Application.EnableEvents = True
End If
End If
End Sub
I would like to achieve the following:
In my excel sheet I have a set of data to which I've applied dynamic filtering by creating a "Search box".
The filtering itself works okay, no problems there, however, I would like to further improve it, by highlighting the text (that is entered into the search box) in the filtered rows in red.
I am attaching a screenshot of what I would like to see in the final version.
Any idea how this can be entered into my current code?
As always, any help is greatly appreciated!
Thank you!
Below is the code I use for the dynamic filtering:
Private Sub TextBox1_Change()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Len(TextBox1.Value) = 0 Then
Sheet1.AutoFilterMode = False
Else
If Sheet1.AutoFilterMode = True Then
Sheet1.AutoFilterMode = False
End If
Sheet1.Range("B4:C" & Rows.Count).AutoFilter field:=1, Criteria1:="*" & TextBox1.Value & "*"
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Consider something like this - Write in a worksheet the following:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target <> Range("a1") Then Exit Sub
SelectAndChange (Target)
End Sub
Private Sub SelectAndChange(strValue As String)
Dim rngCell As Range
Dim rngRange As Range
Dim strLookFor As String
Dim arrChar As Variant
Dim lngCounter As Long
If strValue = vbNullString Then Exit Sub
Application.EnableEvents = False
Set rngRange = Range("E1:E10")
rngRange.Font.Color = vbBlack
strLookFor = Range("A1").Value
For Each rngCell In rngRange
For lngCounter = 1 To Len(rngCell) - Len(strLookFor) + 1
If Mid(rngCell, lngCounter, Len(strLookFor)) = strLookFor Then
rngCell.Characters(lngCounter, Len(strLookFor)).Font.Color = vbRed
End If
Next lngCounter
Next rngCell
Application.EnableEvents = True
End Sub
The values in E1:E10 would be dependent from the value in A1 like this:
The problem is that when I change the value in I16 or I17 I get an error. How
can I prevent this error from happening?
I check in I16 and I17 for the sheetnames, because every week an updated sheet comes available.
Thank you
Sub Compare()
Call compareSheets(range("I16").Value, range("I17").Value)
End Sub
Sub compareSheets(Sofon As String, Sofon2 As String)
Dim mycell As range
Dim mydiffs As Integer
For Each mycell In ActiveWorkbook.Worksheets(Sofon2).range("M:M")
If Not mycell.Value = ActiveWorkbook.Worksheets(Sofon).Cells(mycell.Row, mycell.Column).Value Then
mycell.Interior.Color = vbYellow
mydiffs = mydiffs + 1
End If
Next
MsgBox mydiffs & " differences found in Column M (Salesman)", vbInformation
ActiveWorkbook.Sheets(Sofon2).Select
End Sub
Just to show what I was thinking.
I agree with puzzlepiece87 that On Error is finicky, but with something this simple I would use it to avoid the excess loops.
Sub compareSheets(Sofon As String, Sofon2 As String)
Dim mycell As Range
Dim mydiffs As Integer
On Error GoTo nosheet
For Each mycell In ActiveWorkbook.Worksheets(Sofon2).Range("M:M")
If Not mycell.Value = ActiveWorkbook.Worksheets(Sofon).Cells(mycell.Row, mycell.Column).Value Then
mycell.Interior.Color = vbYellow
mydiffs = mydiffs + 1
End If
Next
MsgBox mydiffs & " differences found in Column M (Salesman)", vbInformation
ActiveWorkbook.Sheets(Sofon2).Select
Exit Sub
nosheet:
If Err.Number = 9 Then
MsgBox "One or both sheets do not exist"
Else
MsgBox Err.Description
End If
End Sub
Since the OP wanted an ISERROR type of solution, I decided to post the code which incorporates a function to check if a sheet exists in a workbook. The concept is similar to answers already posted, but it keeps any On Error statements strictly inside the function and uses regular code blocks to evaluate errors.
Sub Compare()
Dim bGo As Boolean
Dim s1 As String, s2 As String
s1 = Range("I16").Value2
s2 = Range("I17").Value2
If Not WorksheetExist(s1) Then
bGo = False
MsgBox "The sheet " & s1 & " does not exist in this workbook."
End If
If Not WorksheetExist(s2) Then
bGo = False
MsgBox "The sheet " & s2 & " does not exist in this workbook."
End If
If bGo Then compareSheets s1, s2
End Sub
Function WorksheetExist(sName As String, Optional wb As Workbook) As Boolean
Dim wbCheck As Workbook, ws As Worksheet
If wb Is Nothing Then Set wbCheck = ThisWorkbook Else: Set wbCheck = wb
On Error Resume Next
Set ws = wbCheck.Sheets(sName)
On Error GoTo 0
If Not ws Is Nothing Then WorksheetExist = True Else: WorksheetExist = False
End Function
And, based on #puzzlepiece87 methodology, here is an improved WorksheetExist Function that eliminates of On Error statements altogether.
Function WorksheetExist(sName As String, Optional wb As Workbook) As Boolean
Dim wbCheck As Workbook, ws As Worksheet
If wb Is Nothing Then Set wbCheck = ThisWorkbook Else: Set wbCheck = wb
WorksheetExist = False
For Each ws In wbCheck.Worksheets
If ws.Name = sName Then
WorksheetExist = True
Exit For
End If
Next
End Function
You could use something similar to this to call compareSheets. It will warn you if either of the two ranges do not correspond to sheet names and won't call compareSheets if true.
Dim Sheet1 As Worksheet
Dim boolI16SheetCheck As Boolean
Dim boolI17SheetCheck As Boolean
boolI16SheetCheck = False
boolI17SheetCheck = False
For Each Sheet1 in ActiveWorkbook.Worksheets
If Sheet1.Name = Activesheet.Range("I16").Value Then boolI16SheetCheck = True
If Sheet1.Name = Activesheet.Range("I17").Value Then boolI17SheetCheck = True
If boolI16SheetCheck = True And boolI17SheetCheck = True Then
Call compareSheets(range("I16").Value, range("I17").Value)
Exit Sub
End If
Next Sheet1
If boolI16SheetCheck = False Then
If boolI17SheetCheck = False Then
Msgbox "Neither I16 nor I17 sheet found."
Else
Msgbox "I16 sheet not found."
End If
Else
Msgbox "I17 sheet not found."
End If
End Sub