I have tried about 20 different codes, trying to edit them to meet my specifications but have failed.
I have a spreadsheet of data. One column titled "Complete" will either have a date or not have a date (mm/dd/yyyy).
I am trying to write a code for using the ToggleButton to hide and unhide rows with date and leave it alone if there is no date.
Please Try This.
Assuming Your Dates are in Column E.
Private Sub ToggleButton1_Click()
Dim LastRow As Long, c As Range
Application.EnableEvents = False
LastRow = Cells(Cells.Rows.Count, "E").End(xlUp).Row
If ToggleButton1.Value = True Then
'This area contains the things you want to happen
'when the toggle button is depressed
For Each c In Range("E1:E" & LastRow)
If c.Value = "" Then
c.EntireRow.Hidden = True
End If
Next
Else
'This area contains the things you want to happen
'when the toggle button is not depressed
ActiveSheet.Range("E1:E" & LastRow).EntireRow.Hidden = False
End If
End Sub
EDIT 27-06-2016
Modified the program slightly to meet OP's requirement.
Private Sub ToggleButton1_ClickRV()
Dim LastRow As Long, c As Range
Application.EnableEvents = False
LastRow = Cells(Cells.Rows.Count, "E").End(xlUp).Row
If ToggleButton1.Value = True Then
'This area contains the things you want to happen
'when the toggle button is depressed
For Each c In Range("E1:E" & LastRow)
If c.Value <> "" Then
c.EntireRow.Hidden = False
End If
Next
Else
'This area contains the things you want to happen
'when the toggle button is not depressed
ActiveSheet.Range("E1:E" & LastRow).EntireRow.Hidden = True
End If
End Sub
Related
Good day,
I have a report with a pivot table in Excel. My manager asked that when she double clicks in the pivot table, that the source data not be on a new sheet every time. Being a VBA noob, I managed to get assistance online, and I have the following code which does work, however I need some help tweaking it to get my desired result. Please could someone assist me.
Current workbook code:
Private Sub Workbook_NewSheet(ByVal Sh As Object)
If CS <> "" Then
With Application
ScreenUpdating = False
Dim NR&
With Sheets("DrillDown")
If WorksheetFunction.CountA(.Rows(1)) = 0 Then
NR = 1
Else
NR = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows,
SearchDirection:=xlPrevious).Row + 2
End If
Range("A1").CurrentRegion.Copy .Cells(NR, 1)
End With
.DisplayAlerts = False
ActiveSheet.Delete
.DisplayAlerts = True
Sheets(CS).Select
.ScreenUpdating = True
End With
End If
End Sub
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target
As Range, Cancel As Boolean)
If ActiveSheet.Name = "Movement Of Stock" Then
CS = "Movement Of Stock"
ElseIf ActiveSheet.Name = "DrillDown" Then
If Not IsEmpty(Target) Then
If Target.Row > Range("A1").CurrentRegion.Rows.Count + 1 _
Or Target.CurrentRegion.Cells(1, 1).Address = "$A$1" Then
Cancel = True
With Target.CurrentRegion
.Resize(.Rows.Count + 1).EntireRow.Delete
End With
End If
End If
End If
End Sub
Current module code:
Public CS$
The current code works fine, and drops the source data into the DrillDown worksheet, and then brings me back to my pivot table. When I double click somewhere else, again it works, and puts that data under the previous with a row separating.
1) What I would like is that every time I double click in the pivot table, any data in the DrillDown worksheet cleared first, and then new data added (in other words, I don't want the data to stack from each double click).
2) The current code also returns the user back to the pivot table after double clicking. I would like to the user to be taken to the DrillDown sheet rather.
Much appreciated for the assistance!
I believe you can meet your 2 requirements by just making changes to the NewSheet event.
I've commented the changes to make this self explanatory(?)
Private Sub Workbook_NewSheet(ByVal Sh As Object)
If CS <> "" Then
With Application
ScreenUpdating = False
Dim NR&
With Sheets("DrillDown")
'Set this to always start at the top of the page
NR = 1
'..and to clear the Drilldown tab..
.Cells.ClearContents
'instead of this..
' If WorksheetFunction.CountA(.Rows(1)) = 0 Then
' NR = 1
'Else
' NR = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 2
'End If
Range("A1").CurrentRegion.Copy .Cells(NR, 1)
End With
.DisplayAlerts = False
ActiveSheet.Delete
.DisplayAlerts = True
'Below is commented out to stop user being returned to Pivot
' Sheets(CS).Select
.ScreenUpdating = True
End With
End If
End Sub
I am trying to write a code which basically looks at rows 13-33 and deletes the entire row if the cells in Columns B-M are all Blank AND column A is NOT blank.
The first code which I have written below deletes the entire row only if the cell in Column B is blank but I need all the cells in B-M to be blank in order to delete the entire row.
Sub scheduleA()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("Schedule A Template").Select
Dim RowstoDelete As Long
x = 33
For RowstoDelete = Cells(x, 2).End(xlUp).Row To 13 Step -1
If (Cells(RowstoDelete, 2).Value = "0") And (Cells(RowstoDelete, 1).Value <> "") Then
Rows(RowstoDelete).Delete Shift:=xlUp
End If
Next RowstoDelete
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I tried writing it differently as well in the following code but can't achieve the desire result.
Sub DeleteRows()
Dim i As Integer
For i = 33 To 13 Step -1
If WorksheetFunction.CountA(Range("B" & i, "M" & i)) = 0 And WorksheetFunction.CountA(Range("A" & i)) <> "" Then
Rows(i).EntireRow.Delete
End If
Next i
End Sub
Please help!
Your conditions for row deletion are: column A not blank, columns B to M blank. Then something like this should do the trick:
Sub ScheduleA()
On Error GoTo errHandler
Const TOP_ROW As Long = 13
Const BOTTOM_ROW As Long = 33
Dim rowIndex As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook.Worksheets("Schedule A Template")
For rowIndex = .Cells(BOTTOM_ROW, "A").End(xlUp).Row To TOP_ROW Step -1
If Not IsEmpty(.Cells(rowIndex, "A").Value2) Then '...column A is not blank.
If Application.WorksheetFunction.CountA(.Range(.Cells(rowIndex, "B"), .Cells(rowIndex, "M"))) = 0 Then '...all cells on row rowIndex from columns B to M are blank.
.Rows(rowIndex).Delete Shift:=xlUp
End If
End If
Next
End With
Cleanup:
On Error Resume Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Exit Sub
errHandler:
MsgBox Err.Description, vbExclamation + vbOKOnly, "Error"
Resume Cleanup
End Sub
Note that the .Select is gone; you almost never have to select anything to get the job done. Not relying on the selection will make your code much more robust. In the code above, the With block tells the code within it to refer to the target worksheet whenever an expression starts with a period, such as .Cells.
Also, when turning off ScreenUpdating and Calculation, systematically include error handling to turn them back on. This way, if something goes wrong, your code won't leave Excel in an undesirable state.
Finally, instead of referring to worksheets by their tab's name (as seen from Excel), you can refer to them directly using their CodeName, as seen from the VBA editor, in the Properties window, under the worksheet's (Name) property (press Ctrl+R to show the Project Explorer, click on the worksheet under the Microsoft Excel Objects node, then press F4 to display the Properties window). You can change this value; I'd typically change it to shtScheduleATemplate. Then, the With line could be re-written as:
With shtScheduleATemplate
...which would still work even after you changed the worksheet's name from Excel.
EDIT: in your question's code, you are checking column B when determining at which bottom row index to start the loop. However, by doing so, you may miss some rows that should be deleted. I've changed my answer to check within column A instead:
For rowIndex = .Cells(BOTTOM_ROW, "A").End(xlUp).Row To TOP_ROW Step -1
This is a continuation for the following question: What is the cause for Conditional Formatting to get jumbled up?
In an attempt to prevent my conditional formatting from going haywire, I decided to convert it into code in VBA. I decided to start small and start with converting one conditional formatting into VBA.
Explanation:
In column O there are a series of numbers, obtained from a different sheet. User inputs number in column F. For example if number in F9 is less than O9, the font colour will become red. If not number remains normal. The formula should start at row 9 and can continue down onwards and should be automatic.
Meaning the moment a number is keyed in column F the font colour should change instantly.
The following is the code I created so far:
Sub change_color()
With Me.Range("f9", Range("f" & Rows.Count).End(xlUp)) 'so the formula will carry onwards from f9 onwards
If f9 < o9 Then
Range(f).Font.Color = vbRed
End If
End With
End Sub
But alas it didn't work. I also tried linking it to a button and nothing happens. And I also remember to remove my old conditional formatting as well. Is there something I'm missing?
You are after something like the code below.
This code is to be ran once, it will lopp through the entire column "F" in your worksheet, and change the font of all instances.
Regular Module Code
Option Explicit
Sub change_color()
Dim LastRow As Long, i As Long
With Worksheets("Sheet1") ' modify to your sheet's name
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
For i = 1 To LastRow
If .Range("F" & i).Value < .Range("O" & i).Value Then
.Range("F" & i).Font.Color = vbRed
Else
.Range("F" & i).Font.Color = vbBlack
End If
Next i
End With
End Sub
To "catch" the modification in real-time, when someone changes a value in column "F", and then change the font according to the criteria you specified, you need add the following code to the Worksheet module, where you have your data, and add the piece of code below to Worksheet_Change event.
Code in Sheet1 module (modify to your sheet's)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 6 Then ' if someone changes a value in column "F"
Application.EnableEvents = False
If Target.Value < Range("O" & Target.Row).Value Then
Target.Font.Color = vbRed
Else
Target.Font.Color = vbBlack
End If
End If
Application.EnableEvents = True
End Sub
Does this work for you?
Option explicit
Sub ChangeColor()
With thisworkbook.worksheets(YOURSHEETNAME) 'Replace with sheet name as per your workbook.'
Dim LastRow as long
Lastrow = .cells(.rows.count,"F").end(xlup).row
Dim RowIndex as long
For rowindex = 9 to LastRow
If .cells(rowindex,"F").value2 < .cells(rowindex,"O").value2 then
.cells(rowindex,"F").font.color = vbred
End if
Next rowindex
End With
End Sub
I wrote a small VBA macro to compare two worksheets and put unique values onto a new 3rd worksheet.
The code works, but every time I use if excel goes "not responding" and after 30-45sec comes back and everything worked as it should.
Can I make this faster and get rid of the "not responding" issue? is it just my computer not being fast enough?
I start with about 2500-2700 rows in each sheet I'm comparing.
Sub FilterNew()
Dim LastRow, x As Long
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "New" 'Adds a new Sheet to store unique values
Sheets(1).Rows("1:1").Copy Sheets("New").Rows("1:1") 'Copies the header row to the new sheet
Sheets(1).Select
LastRow = Range("B1").End(xlDown).Row
Application.ScreenUpdating = False
For Each Cell In Range("B2:B" & LastRow)
x = 2 'This is for looking through rows of sheet2
Dim unique As Boolean: unique = True
Do
If Cell.Value = Sheets(2).Cells(x, "B").Value Then 'Test if cell matches any cell on Sheet2
unique = False 'If the cells match, then its not unique
Exit Do 'And no need to continue testing
End If
x = x + 1
Loop Until IsEmpty(Sheets(2).Cells(x, "B"))
If unique = True Then
Cell.EntireRow.Copy Sheets("New").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
Next
Application.ScreenUpdating = True
End Sub
This belongs in Code Review, but here is a link
http://www.excelitems.com/2010/12/optimize-vba-code-for-faster-macros.html
With your code your main issues are:
Selecting/Activating Sheets
Copy & pasting.
Fix those things and youll be set straight my friend :)
instead of a do...loop to find out duplicate, I would use range.find method:
set r = SHeets(2).range("b:b").find cell.value
if r is nothing then unique = true else unique = false
(quickly written and untested)
What about this (it's should help):
Sub FilterNew()
Dim Cel, Rng As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "New" 'Adds a new Sheet to store unique values
Sheets(1).Rows("1:1").Copy Sheets("New").Rows("1:1") 'Copies the header row to the new sheet
Set Rng = Sheet(1).Range("B2:B" & Sheet(1).Range("B1").End(xlDown).Row)
For Each Cel In Rng
If Cel.Value <> Sheet(2).Cells(Cel.Row, 2).Value Then Cel.EntireRow.Copy Sheets("New").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) ' The only issue I have with this is that this doesn't actually tell you if the value is unique, it just tells you ins not on the same rows of the first and second sheet - Is this alright with you?
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I have read a number of posts about hiding rows in Excel, and they all helped me with the hiding, but I still don't seem to find any solutions for why it will not UNHIDE.
I am using the following code:
Private Sub Worksheet_Calculate()
Dim LastRow As Long, c As Range
Application.EnableEvents = False
LastRow = Cells(Cells.Rows.Count, "D").End(xlUp).Row
On Error Resume Next
For Each c In Range("D116:D" & LastRow)
If c.Value = 0 Then
c.EntireRow.Hidden = True
ElseIf c.Value > 0 Then
c.EntireRow.Hidden = False
End If
Next
On Error GoTo 0
Application.EnableEvents = True
End Sub
If I start with some 1 and some 0 values, then the code successfully hides the rows with value 0, AND also continues to be active, ensuring that any values I later change from 1 to 0 are automatically hidden.
However, the values that were initially 0, once changed to 1, will not UNHIDE automatically. This is a big problem because I intend to start with all zero values, and then unhide rows as these values change to 1 or greater than 1. It's worth of note that these values in column D are references to somewhere else in the same spreadsheet (just for instance =N100), so that I can control the values even when the rows are hidden. I didn't think the use of a formula was a problem because it can still respond to dynamic changes to HIDE (when changed from 1 to 0), just not to UNHIDE.
Any suggestions?
Thanks to all who helped. Thanks to Ads help I created a macro, and from that code I got the line that I was missing: Activate. The code now works as:
Private Sub Worksheet_Calculate()
Dim LastRow As Long, c As Range
Application.EnableEvents = False
LastRow = Cells(Cells.Rows.Count, "D").End(xlUp).Row
On Error Resume Next
For Each c In Range("D116:D" & LastRow)
If c.Value = 0 Then
c.EntireRow.Hidden = True
ElseIf c.Value > 0 Then
c.Activate
c.EntireRow.Hidden = False
End If
Next
On Error GoTo 0
Application.EnableEvents = True
End Sub
I'm not sure exactly how to show a row in VBA, what you have looks right to show a row. But when I was ever unsure how to do something, I would record a macro to do what I wanted to achieve and then just review the code that excel generates.