I am having problem to make this code work - any help is much appreciated! I know the issue is to do with the first line...I have a Private Sub Worksheet_Change(ByVal Target As Range) above this code to address other elements that I need VBA code for.
Private Sub HideAndUnhideRowsInOtherWorksheet()
For Each c In Worksheets("FlatStage").Range("A7:A32")
If c.Value = "" Then
c.EntireRow.Hidden = True
Else
c.EntireRow.Hidden = False
End If
Next
For Each c In Worksheets("Efficiency").Range("A7:A32")
If c.Value = "" Then
c.EntireRow.Hidden = True
Else
c.EntireRow.Hidden = False
End If
Next
For Each c In Worksheets("DayRate").Range("A7:A10,A14:A22,A25:A25,A28:A39")
If c.Value = "" Then
c.EntireRow.Hidden = True
Else
c.EntireRow.Hidden = False
End If
Next
For Each c In Worksheets("AddServ").Range ("A6:A8,A10:A11,A13:A17")
If c.Value = "" Then
c.EntireRow.Hidden = True
Else
c.EntireRow.Hidden = False
End If
Next
For Each c In Worksheets("Enhancement").Range("A6:A7")
If c.Value = "" Then
c.EntireRow.Hidden = True
Else
c.EntireRow.Hidden = False
End If
Next
End Sub
If you call the code from the above Worksheet_Change() it should work, but if you call your Sub from another module it will not be visible because it's declared as Private (to that particular module)
All you need to do is change Private to Public
(or move it to a new generic module and make it Public there)
On the other hand, the screen might flash while it is executing
To fix this turn off ScreenUpdating before the loops, and turn it back on after
But you can also reduce the code so it will be easier to maintain:
Option Explicit
Public Sub HideAndUnhideRowsInOtherWorksheet()
Application.ScreenUpdating = False
ToggleRows Worksheets("FlatStage").Range("A7:A32")
ToggleRows Worksheets("Efficiency").Range("A7:A32")
ToggleRows Worksheets("DayRate").Range("A7:A10,A14:A22,A25:A25,A28:A39")
ToggleRows Worksheets("AddServ").Range("A6:A8,A10:A11,A13:A17")
ToggleRows Worksheets("Enhancement").Range("A6:A7")
Application.ScreenUpdating = True
End Sub
Private Sub ToggleRows(ByRef colRng As Range)
If Not colRng Is Nothing Then
Dim c As Range
For Each c In colRng
c.EntireRow.Hidden = Len(c.Value2) = 0
Next
End If
End Sub
Or, even smaller and faster if you can use AutoFilter:
Private Sub FilterRows(ByRef colRng As Range)
If Not colRng Is Nothing Then
colRng.Parent.UsedRange.Columns(colRng.Column).AutoFilter 'Filter symbol in top cell
colRng.AutoFilter Field:=1, Criteria1:="<>"
End If
End Sub
This sub will unhide all rows in all worksheets
Public Sub UnhideAllRowsInAllWorksheets()
Dim ws As Worksheet
For Each ws In Worksheets
With ws.UsedRange
If ws.AutoFilterMode Then .AutoFilter 'ws.ShowAllData
.Rows.EntireRow.Hidden = False
End With
Next
End Sub
Related
I would like to lock cells in a worksheet when data is entered. Also, the administrator would have access to unprotect the worksheet when changes have to be made. But with this code I have the following issues:
When data is entered and then the sheet it unprotected for deleting the data, the code then is unable to allow rentry of data into the same cells from where data was deleted, is there a good method to enable this?
I have tried a few options that relate to Target.Cells, ActiveSheet.UsedRange, ActiveSHeet.OnEntry and Application.OnKey but nothing seems to override the delete/baackspace event.
Any help would be appreciated. This is the current code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ToLock As String
Dim R As Range
Application.ScreenUpdating = False
ToLock = MsgBox("This input will now be locked.", vbOKCancel, "Confirm Change")
''If locking is accepted
If ToLock <> vbOK Then
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
Exit Sub
End If
''Once entry entered, sheet will be locked with this password
ActiveSheet.Unprotect "quality"
' For Each R In ActiveSheet.UsedRange
For Each R In Target.Cells
If R.Value <> "" Then
Target.Locked = True
End If
Next R
ActiveSheet.Protect Password:="quality", DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = True
End Sub
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rnCell As Range, rnEmpty As Range
On Error Resume Next
Set rnEmpty = emptyCells(Target)
If Not (rnEmpty Is Nothing) Then
If rnEmpty.Address = Target.Address Then Exit Sub
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo ChangeEnd
If MsgBox("This input will now be locked.", vbOKCancel, "Confirm Change") = vbCancel Then
Target.ClearContents
GoTo ChangeEnd
End If
ActiveSheet.Unprotect "quality"
Target.Locked = True
Set rnEmpty = emptyCells(ActiveSheet.UsedRange)
If Not (rnEmpty Is Nothing) Then rnEmpty.Locked = False
ChangeEnd:
ActiveSheet.Protect Password:="quality", DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Function emptyCells(rnIn As Range) As Range
On Error Resume Next
If rnIn.Cells.Count = 1 Then
If (rnIn.Value = vbNullString) And (rnIn.Formula = vbNullString) Then
Set emptyCells = rnIn
End If
Else
Set emptyCells = rnIn.SpecialCells(Type:=xlCellTypeBlanks)
End If
End Function
Some changes were introduced for readability, some others to fit functionality you seek for, others to avoid looping. Hope that helps... any questions, please comment and will add explanation.
It should work when you paste ranges (empty cells will still be editable)
I am running two VBA formulas.
The first hides all cells with empty information the first column.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range
On Error Resume Next
Application.ScreenUpdating = False
For Each c In Range("A3:A49")
If c.Value = vbNullString Then
c.EntireRow.Hidden = True
End If
Next c
For Each c In Range("A3:A47")
If c.Value <> vbNullString Then
c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
The second Formula strings data together and placeses this information in the next cell that is empty (aka the first hidden cell) when the button is clicked.
Option Explicit
Dim iwsh As Worksheet
Dim owsh As Worksheet
Dim output As String
Dim i As Integer
Sub Copy()
Set iwsh = Worksheets("Budget")
Set owsh = Worksheets("Release Burnup")
i = 3
While owsh.Cells(i, 1) <> ""
i = i + 1
Wend
output = "R" & iwsh.Cells(13, 2).Value & "-S" & iwsh.Cells(14, 2).Value
owsh.Cells(i, 1) = output
ActiveSheet.EnableCalculation = False
ActiveSheet.EnableCalculation = True
End Sub
Previously, this has been causing no problem... Something has happened that is causing the workbook to crash anytime I try to delete information out of one of the cells with the new data.
PS: This is the list of my other formulas. maybe there is something in these that is interacting with the formentioned code?
Private Sub NewMemberBut_Click()
'causes userform to appear
NewMember.Show
'reformats button because button kept changing size and font
NewMemberBut.AutoSize = False
NewMemberBut.AutoSize = True
NewMemberBut.Height = 40.25
NewMemberBut.Left = 303.75
NewMemberBut.Width = 150
End Sub
'Similar code to the problematic code in question, but this one works fine
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range
On Error Resume Next
Application.ScreenUpdating = False
For Each c In Range("A3:A35,A41:A80")
If c.Value = vbNullString Then
c.EntireRow.Hidden = True
End If
Next c
For Each c In Range("A3:A35,A41:A80")
If c.Value <> vbNullString Then
c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
'Code for UserForm
Option Explicit
Dim mName As String
Dim cName As String
Dim mRole As String
Dim cRole As String
Dim i As Integer
Dim x As Integer
Dim Perc As Integer
Dim Vac As Integer
Dim Prj As Worksheet
Dim Bud As Worksheet
Private Sub NewMember_Initialize()
txtName.Value = ""
cboRoleList.Clear
Scrum.Value = False
txtPercent.Value = ""
txtVacation.Value = ""
txtName.SetFocus
End Sub
Private Sub AddMember_Click()
If Me.txtName.Value = "" Then
MsgBox "Please enter a Member name.", vbExclamation, "New Member"
Me.txtName.SetFocus
Exit Sub
End If
If Me.cboRoleList = "Other" And Me.txtCustomRole = "" Then
MsgBox "Please provide a role name.", vbExclamation, "Other Role"
Exit Sub
End If
If Me.cboRoleList.Value = "" Then
MsgBox "Please select a Role.", vbExclamation, "Member Role"
Me.cboRoleList.SetFocus
Exit Sub
End If
If Me.cboRoleList <> "Other" And Me.txtPercent = "" Then
MsgBox "Please select a valid percentage to be applied to this sprint.", vbExclamation, "Sprint Percent"
Me.txtPercent.SetFocus
Exit Sub
End If
If Me.txtPercent.Value > 100 And Me.txtPercent <> "" Then
MsgBox "Please select a valid percentage to be applied to this sprint.", vbExclamation, "Sprint Percent"
Me.txtPercent.SetFocus
Exit Sub
End If
If Me.txtVacation.Value = "" Then
Me.txtVacation.Value = 0
End If
Dim i As Long
Set Prj = Worksheets("Project Team")
Set Bud = Worksheets("Budget")
Prj.Activate
i = 5
x = 1
If Me.cboRoleList.Value = "Other" Then
i = 46
End If
While Prj.Cells(i, 1) <> ""
i = i + 1
Wend
If cboRoleList = "Other" Then
Cells(i, x).Value = txtCustomRole.Value
End If
If cboRoleList <> "Other" Then
Cells(i, x).Value = cboRoleList.Value
End If
x = x + 1
Cells(i, x).Value = txtName.Value
x = x + 1
If Me.cboRoleList.Value <> "Other" Then
Cells(i, x).Value = txtPercent.Value
End If
Unload Me
End Sub
Private Sub CloseBut_Click()
Unload Me
End Sub
Change the event driven Worksheet_SelectionChange to Worksheet_Change and isolate further by only processing when something changes in A3:A49.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A3:A49")) Is Nothing Then
On Error GoTo safe_exit
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim c As Range
For Each c In Intersect(Target, Range("A3:A49"))
c.EntireRow.Hidden = CBool(c.Value = vbNullString)
Next c
End If
safe_exit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Caveat: A Worksheet_Change is not triggered on the change in a cell from the cell's formula. Only by typing, deleting or dragging a cell's contents. Adding or removing a formula will trigger it but not when a formula's result changes from another value somewhere in the workbook changing. This should not affect you as no formula can return vbNullString but it is worth mentioning for others.
Hi guys I made the code below to search for multiple text in a given column. The problem is that it is very slow. Do guys know any other ways to perform it faster?
For example give the array ('foo', 'bar'), The code should iterate on a column and match/filter only the rows that have both texts in any given order.
Sub aTest()
ScreenUpdating = False
Dim selectedRange As Range, cell As Range
Dim searchValues() As String
searchValues = Split(ActiveSheet.Cells(2, 1).Value)
Set selectedRange = Range("A4:A40000")
Dim element As Variant
For Each cell In selectedRange
If cell.Value = "" Then
Exit For
Else
For Each element In searchValues
If Not InStr(1, cell.Value, element) Then
cell.EntireRow.Hidden = True
End If
Next element
End If
Next cell
ScreenUpdating = True
End Sub
I was using it as a filter. copied and pasted the following code with a few modifications. But then I was not able to make the changes to match multiple strings.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim iFilterColumn As Integer
Dim rFilter As Range
Dim sCriteria As String
On Error Resume Next
With Target
Set rFilter = .Parent.AutoFilter.Range
iFilterColumn = .Column + 1 - rFilter.Columns(1).Column
If Intersect(Target, Range("rCriteria")) Is Nothing Then GoTo Terminator
Select Case Left(.Value, 1)
Case ">", "<"
sCriteria = .Value
Case Else
sCriteria = "=*" & .Value & "*"
End Select
If sCriteria = "=" Then
.Parent.Range(rFilter.Address).AutoFilter Field:=iFilterColumn
Else
.Parent.Range(rFilter.Address).AutoFilter Field:=iFilterColumn, Criteria1:=sCriteria
End If
End With
Terminator:
Set rFilter = Nothing
On Error GoTo 0
End Sub
I'm assuming this:
Set selectedRange = Range("A4:A40000")
It's because the size is not defined properly, the following should limit to the right long
Set selectedRange = Range("A4:A" & Cells(Rows.Count, "A").End(xlUp).Row)
If it doesn't affect, I always use these codes to speed up Excel (Instead of only ScreenUpdating alone).
Sub ExcelNormal()
With Excel.Application
.Cursor = xlDefault
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
End Sub
Sub ExcelBusy()
With Excel.Application
.Cursor = xlWait
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
.StatusBar = False
End With
End Sub
Note: In the future Probably Code Review would be better place to post.
This would be a very simple question.
But I am not sure why this is not working in my excel vba code.
Sheets("I- ABC").Select
If IsEmpty(Range("A3").Value) = True And _
IsEmpty(Range("A4").Value) = True And _
IsEmpty(Range("A5").Value) = True And _
IsEmpty(Range("A6").Value) = True Then
Sheets("I- ABC").Delete
End If
What type of error do you get? I tried this code and Excel displays only warning message:
You can avoid this message by adding:
Application.DisplayAlerts = False
and
Application.DisplayAlerts = True
at the beginning and at the end of your code respectively.
--Edited code
Sub Example()
Application.DisplayAlerts = False
With Sheets("I- ABC")
If Application.WorksheetFunction.CountA(.Range("A3:A6")) = 0 Then
.Delete
End If
End With
Application.DisplayAlerts = True
End Sub
Try Similiar to This
Sub Test()
Application.DisplayAlerts = False
With Sheets("Sheet1")
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
Application.DisplayAlerts = True
End Sub
PS: It works for me and deletes rows containg empty cells in `A:A``
Approach Suggested by #Tim Williams also works for me as per following code in my situation
Sub Test6()
Dim r As Range, rows As Long, i As Long
Set r = ActiveSheet.Range("A3:A6")
rows = r.rows.Count
For i = rows To 1 Step (-1)
If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete
Next
End Sub
It works even if we use Application instead of WorksheetFunction
If If Application.CountA(Range("A3:A6")) = 0 Then is not working as Tim suggested then that means the cells have blank spaces or unprintable characters.
Try this
Sub Sample()
Dim pos As Long
With Sheets("I- ABC")
pos = Len(Trim(.Range("A3").Value)) + _
Len(Trim(.Range("A4").Value)) + _
Len(Trim(.Range("A5").Value)) + _
Len(Trim(.Range("A6").Value))
If pos = 0 Then
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Else
MsgBox "The cells are not empty"
End If
End With
End Sub
With skkakkar's idea expanded.
Sub Hello()
Dim rng As Range
Application.DisplayAlerts = 0
On Error GoTo er
Set rng = Range("A3:A6").SpecialCells(xlCellTypeConstants, 23)
Exit Sub
er: MsgBox "ActiveSheet.Delete" 'delete sheet
End Sub
If the spaces are the issue, then you can try this code:
Public Sub RemoveIfEmpty()
Application.DisplayAlerts = False
With Sheets("I- ABC")
If Trim(.Range("A3") & .Range("A4") & .Range("A5") & .Range("A6")) = "" Then
.Delete
End If
End With
Application.DisplayAlerts = True
End Sub
Option Explicit
Public PlotName As String
Public PlotRange As Range
Sub Tester()
Range("TCKWH.V.1").Select
AddPlot ActiveSheet.Range("KWH_G_1")
End Sub
Sub AddPlot(rng As Range)
With ActiveSheet.Shapes.AddChart
PlotName = .Name
.Chart.ChartType = xlLineMarkers
.Chart.SetSourceData Source:=Range(rng.Address())
.Chart.HasTitle = True
.Chart.ChartTitle.Text = Range("KWH.G.1")
.Chart.Axes(xlValue, xlPrimary).HasTitle = True
.Chart.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = Range("KWH.G.1")
End With
Set PlotRange = rng
Application.EnableEvents = False
rng.Select
Application.EnableEvents = True
End Sub
Sub FixPlott(rng As Range)
Dim n As Long
With ActiveSheet.Shapes(PlotName)
For n = .SeriesCollection.Count To 1 Step -1
With .SeriesCollection(n)
If PlotName = "" Then
.Delete
End If
End With
Next n
End With
End Sub
Sub RemovePlot(rng As Range)
If Not PlotRange Is Nothing Then
If Application.Intersect(rng, PlotRange) Is Nothing Then
On Error Resume Next
rng.Parent.Shapes(PlotName).Delete
On Error GoTo 0
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
RemovePlot Target
Application.ScreenUpdating = True
End Sub
I need help with Sub FixPlott. I am trying to get it to delete the Legend Entries on the Legend Key. For example if I select Main Campus and South Hall there will be blank legend entries for dunblane and greensburg. Id like the legend just to show selected buildings.
Here you have a corrected version of your sub:
Sub FixPlott(PlotName As String)
Dim n As Long
With ActiveSheet.Shapes(PlotName).Chart
For n = .SeriesCollection.Count To 1 Step -1
With .SeriesCollection(n)
If .Name = "" Then
ActiveSheet.Shapes(PlotName).Chart.Legend.LegendEntries(n).Delete
End If
End With
Next n
End With
End Sub
I am not sure about the exact trigger you want to use. So I have included a simple string trigger; if the given SeriesCollection is called like trigger, the legend will be deleted.