Format Range when cell value entered - excel

I have a template where the user enters account information and the default range for information is range B18 to S52. This fits nicely onto the screen and is a big enough range for the details being entered 90% of the time. However on a few occasions the use may have data that is a few hundred rows. Its usally copied and pasted in but would make the sheet look messy as it would be out of the default range.
I'm trying make the formatting dynamic where by if the user enters data outside of the default range a macro is triggered that will count the rows and reformat the range.
The code I have so far from researching online is:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$18" Then
Call CountLoc
End If
End Sub
Public Sub CountLoc()
With Application
.DisplayAlerts = False
'.Calculation = xlManual
.EnableEvents = False
.ScreenUpdating = False
End With
Dim LocCount As Long
Dim WsInput As Worksheet
Dim i As Long
Dim rng As Range
Set WsInput = Sheets("Account Input")
With WsInput
LocCount = .Range("B1048576").End(xlUp).row - 17
End With
If LocCount > 35 Then
Set rng = WsInput.Range(WsInput.Cells(18, 2), WsInput.Cells(17 + LocCount, 19))
With rng
.Interior.Color = RGB(220, 230, 241)
.Borders.LineStyle = xlContinuous
.Borders.Color = vbBlack
.Borders.Weight = xlThin
End With
For i = 1 To LocCount Step 2
Rows(18 + i).EntireRow.Interior.Color = vbWhite
Next i
Else
Exit Sub
End If
This essentially colors every other row light blue and white and adds a border to each cell. The Count Loc works fine and does what I need it to do but the problem I have is that I cannot get the worksheet_Change to trigger.
Thanks in advance

there
I ran a little test using your code and the first thing I noticed, is that you set the Application.EnableEvents to False and you don't set it back on, so you are cancelling any event like the Worksheet_Change Event once that's fix the event will trigger any time the cell B18 changes, except if the value that is entered comes from a paste(not sure why) but if you use the Intersect method then it works even if the value came from a copy paste.
I did some small tweeks to your code and I think it works now. please review it and give it a try.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, ThisWorkbook.Sheets("Account Input").Range("B18")) Is Nothing Then
Call CountLoc
End If
End Sub
Public Sub CountLoc()
Dim LocCount As Long
Dim WsInput As Worksheet
Dim i As Long
Dim rng As Range
Set WsInput = Sheets("Account Input")
With WsInput
LocCount = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
If LocCount > 35 Then
Set rng = WsInput.Range(WsInput.Cells(18, 2), WsInput.Cells(LocCount, 19))
With rng
.Interior.Color = RGB(220, 230, 241)
.Borders.LineStyle = xlContinuous
.Borders.Color = vbBlack
.Borders.Weight = xlThin
End With
For i = 18 To LocCount Step 2
Set rng = WsInput.Range(WsInput.Cells(i, 2), WsInput.Cells(i, 19))
rng.Interior.Color = vbWhite
Next i
Else
Exit Sub
End If
End Sub

Related

How to check for duplicates, highlight duplicates, and count the highlighted duplicates in a single column?

I want to highlight and count the number of duplicates in a single concatenated column.
I have it as two separate subs right now and there really isn't much more to say, this isn't that hard of a problem I'm confident of that but I have been working on it for days with absolutely no progress. It has to be done in a VBA and it cannot highlight blank cells in the column. The concatenations are done through a formula in the workbook. Please help me, I m dying,
Sub Duplicate_Check()
Dim ws As Worksheet
Set ws = Sheet1
Worksheets("Master Checklist").Activate
Columns("H:H").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Interior
.ColorIndex = 40
.TintAndShade = 0
End With
'Sheet2.Range(“L2").Value = Application.WorksheetFunction.Countif(Columns("H:H")), cell.Font.Color = "-16383844")
'Range(“B10?).Value = Application.WorksheetFunction.Countif(Range(“A2:A8?), “>” & 50
End Sub
Sub CountDupes()
Dim countofDupes As Long
Dim rng As Range
Dim myCell As Range
countofDupes = 0
Set rng = Range("H2").End(xlDown)
For Each myCell In rng
If myCell.Interior.ColorIndex = 40 Then
countofDupes = countofDupes + 1
Debug.Print countofDupes
End If
Next myCell
End Sub
I don't encounter any error messages but if I Debug.Print countofDupes I get nothing returned, which it obviously not what I want. Any advice?

Convert selected cells formula to value across Selected Sheets

I'm using this code below to convert formula to cells, which works fine in a single sheet. But the problem is when I need to convert all selected cells which are in different sheets to their value, this code doesn't do it.
This is how I am selecting the cells in Excel:
first I select the cells in one sheet, than I go down to the tabs right-click and select specific sheets, which in Excel selects the corresponding cells in every selected sheet.
So any tips on how I can change this code to make it work across different sheets?
Sub formulaToValues()
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each cel In Selection.Cells
cel.Value = cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
End If
End Sub
You should be able to just grab the address of the selection, then add that to each worksheet's range
Sub formulaToValues()
Dim celAddr As String
celAddr = Selection.Address
Dim ws As Worksheet
For Each ws In ActiveWindow.SelectedSheets
With ws.Range(celAddr)
.Value = .Value
.Interior.ColorIndex = 0
.Font.Color = vbBlack
End With
Next ws
End Sub
You are attempting to write to a 3D cell collection. An interesting problem i haven't seen before. I gave it a shot.
The below code works for me. I have simply added an extra loop to search through any other sheets. Note: it is good practice to always declare your variables.
Answer1: This cycles through every sheet in the workbook
Sub formulaToValues()
Dim cel As Range
Dim ws As Worksheet
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each ws In ThisWorkbook.Worksheets
For Each cel In Selection.Cells
ws.Range(cel.Address).Value = 2 'cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
Next ws
End If
End Sub
Answer2: With this one it only goes throug the selected sheets
Sub formulaToValues()
Dim cel As Range
Dim ws As Worksheet
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each ws In ThisWorkbook.Windows(1).SelectedSheets
For Each cel In Selection.Cells
ws.Range(cel.Address).Value = 2 'cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
Next ws
End If
End Sub
Thanks alot guys, this got answered pretty quickly.
I am placing my macros in personal so I ended if with this
Sub formulaToValues3()
Dim cel As Range
Dim ws As Worksheet
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each ws In ActiveWorkbook.Windows(1).SelectedSheets
For Each cel In Selection.Cells
ws.Range(cel.Address).Value = ws.Range(cel.Address).Value 'cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
Next ws
End If
End Sub

Automatically hide corresponding rows based on cell value

I tried writing macros wherein rows are hidden based on a cell value (which is a Data Validation dropdown):
Using the following code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target = Range("C15") Then
BeginRow = 17
EndRow = 25
ChkCol = 4
For RowCnt = BeginRow To EndRow
If Cells(RowCnt, ChkCol).Value = Cells(15, 3).Value Then
Cells(RowCnt, ChkCol).EntireRow.Hidden = False
Else
Cells(RowCnt, ChkCol).EntireRow.Hidden = True
End If
Next RowCnt
End If
exitHandler:
Application.EnableEvents = True
End Sub
It is doing the thing I need but the problems I'm facing are, it is taking time for any change in C15 (actual data has around 100 rows) and also when I'm trying to make any changes in rest of the sheet, it throws an error -
"Run-time error '13': Type Mismatch".
I have no macros experience and I'm not sure what I'm doing wrong. Could you please help me correct the code. If there is a better way to achieve the same task in a more efficient way, please do let me know.
Looping through a few 100 (or even a few thousand) rows checking the hidden property will run fast enough. Key points are to limit the checking to only the required cells, and do the Hide/Unhide in one operation (this is the slow bit if done a row at a time)
Using the logic:
If Cell C15 changes, check the whole list, or
If one or more cells change in the list D17:D25 (or larger) process only changed cells
Build a reference to rows that must change hidden state, and set the Hidden property for the whole range
This code runs virtually instantly on a List range of a few 1000 rows
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim cl As Range
Dim rTest As Range, vTest As Variant
Dim rList As Range
Dim rHide As Range, rUnhide As Range
On Error GoTo EH
Application.EnableEvents = False
Application.ScreenUpdating = False
Set rTest = Me.Cells(15, 3) ' Cell to compare to
Set rList = Me.Range("D17:D25") ' List of cells to compare to the Test cell
If Not Application.Intersect(Target, rTest) Is Nothing Then
' Test cell has changed, so process whole list
Set rng = rList
Else
' Only process changed cells in the list
Set rng = Application.Intersect(Target, rList)
End If
If Not rng Is Nothing Then
' there is somthing to process
vTest = rTest.Value
For Each cl In rng.Cells
If cl.EntireRow.Hidden Then
' the row is already hidden
If cl.Value = vTest Then
' and it should be visible, add it to the Unhide range
If rUnhide Is Nothing Then
Set rUnhide = cl
Else
Set rUnhide = Application.Union(rUnhide, cl)
End If
End If
Else
' the row is already visible
If cl.Value <> vTest Then
' and it should be hidden, add it to the Hide range
If rHide Is Nothing Then
Set rHide = cl
Else
Set rHide = Application.Union(rHide, cl)
End If
End If
End If
Next
' do the actual hiding/unhiding in one go (faster)
If Not rUnhide Is Nothing Then
rUnhide.EntireRow.Hidden = False
End If
If Not rHide Is Nothing Then
rHide.EntireRow.Hidden = True
End If
End If
EH:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Using the Find method may be quicker for you:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo exitHandler
Application.EnableEvents = False
If Target.Address = "$C$15" Then
Rows("17:25").EntireRow.Hidden = True
Dim rng As Range
Set rng = Me.Range("D17:D25").Find(What:=Target.Value, LookAt:=xlWhole)
If Not rng Is Nothing Then rng.EntireRow.Hidden = False
End If
exitHandler:
Application.EnableEvents = True
End Sub
Rather than iterating over every row one-by-one, this version first hides all rows in the range, and then unhides the appropriate row, if found.
In order to prevent the error you need to use the error handler. The error will occur in case you select more than one cell and try to delete them
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const BeginRow = 17
Const EndRow = 25
Const ChkCol = 4
Dim RowCnt As Long
On Error GoTo exitHandler
Application.EnableEvents = False
If Target = Range("C15") Then
For RowCnt = BeginRow To EndRow
If Cells(RowCnt, ChkCol).Value = Cells(15, 3).Value Then
Cells(RowCnt, ChkCol).EntireRow.Hidden = False
Else
Cells(RowCnt, ChkCol).EntireRow.Hidden = True
End If
Next RowCnt
End If
exitHandler:
Application.EnableEvents = True
End Sub
EDIT Based on QHarr's idea to use the Autofilter
Private Sub Worksheet_Change(ByVal Target As Range)
Const BeginRow = 17
Const EndRow = 25
Const ChkCol = 4
Dim RowCnt As Long
On Error GoTo EH
'If you want to prevent error 13 you could uncomment the following line
'If Target.Cells.CountLarge > 1 Then Exit Sub
Application.EnableEvents = False
If Target = Range("C15") Then
Dim filterRange As Range
Set filterRange = Range(Cells(BeginRow - 1, ChkCol), Cells(EndRow, ChkCol))
filterRange.AutoFilter
filterRange.AutoFilter Field:=1, Criteria1:=Target
End If
EH:
Application.EnableEvents = True
End Sub
EDIT2 The reason for the run-time error 13 is the line Target = Range("C15"). In case you select more than one cell you compare a range with a value because Range("C15") always returnes the value of that cell. As QHarr changed his code after our discussion to Target.Address = Range("C15").Address this error cannot occur any longer.
You could use Autofilter which will be quick.
You can easily change BeginRow, EndRow and ChkCol to adjust range and code still works.
Set to Criteria1:="<>" & Target if you want to show only those not like the selected item.
0.008 seconds for 10000 rows.
Code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim BeginRow As Long
Dim EndRow As Long
Dim ChkCol As Long
Dim RowCnt As Long
With ActiveSheet
If Target.Address = Range("C15").Address Then
BeginRow = 17
EndRow = 25
ChkCol = 4
Dim filterRange As Range
Set filterRange = .Range(.Cells(BeginRow - 1, ChkCol - 1), .Cells(EndRow, ChkCol))
filterRange.AutoFilter
filterRange.AutoFilter Field:=1, Criteria1:= Target
End If
End With
End Sub

Clear the contents of columns B to F if cell A is empty

I have a worksheet with values depending on Cell A. If a row in column A contains a value then cells from Columns B through H will be changed accordingly.
If Cell of Column A is empty I want to reset the cells from columns D through F.
I wrote down the following VBA Code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim n As Integer
For n = 5 To 75
Application.EnableEvents = False
If VarType(Cells(n, 1)) = vbEmpty Then
Cells(n, 4).ClearContents
Cells(n, 5).ClearContents
Cells(n, 6).ClearContents
Application.EnableEvents = True
End If
Next n
End Sub
The "FOR" Loop is annoying, and making the Excel to pause for 1 second or more after any entry to any Cell, can anyone help me correct the above code to do what I need to do without the "FOR" loop.
You are using a Worksheet_Change event and you iterating through 70 rows each time something changes.. this is a bad approach for this kind of problem and that's why there is a delay.
Instead, try
Private Sub Worksheet_Change(ByVal Target As Range)
Dim n As Long
If Target.Column = 1 Then
If IsEmpty(Cells(Target.Row, 1)) Then
Range("B" & Target.Row & ":F" & Target.Row).ClearContents
End If
End If
End Sub
this will only clear the cells if you remove a value from column A => when cell in column A is empty
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
If Mid(Target.Address(1, 1), 1, 2) = "$A" Then
If Target.Cells(1, 1).Value = "" Then
For i = 4 To 6
Target.Cells(1, i).Value = ""
Next i
End If
End If
End Sub
Give this a try:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rLook As Range, r As Range, Intr As Range
Set rLook = Range("A5:A75")
Set Intr = Intersect(rLook, Target)
If Intr Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Intr
If r.Value = "" Then
rw = r.Row
Range("D" & rw & ":F" & rw).ClearContents
End If
Next r
Application.EnableEvents = True
End Sub
It should have minimal impact on timing.
Use a range object.
The following line of code will print the address of the Range we'll use to clear the contents. The first cells call gets the upper left corner of the range, the second cells call gets the lower right corner of the range.
Private Sub test()
Debug.Print Range(Cells(5, 4), Cells(75, 6)).Address
End Sub
We apply this to your code like this:
Private Sub Worksheet_Change(ByVal Target As Range)
If VarType(Cells(Target.Row, 1)) = vbEmpty Then
Application.EnableEvents = False
Range(Cells(Target.Row, 4), Cells(Target.Row, 6)).ClearContents
Application.EnableEvents = True
End If
End Sub
One final sidenote: You should use an error handler to make sure events are always enabled when the sub exits, even if an error occurs.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrHandler
If VarType(Cells(Target.Row, 1)) = vbEmpty Then
Application.EnableEvents = False
Range(Cells(Target.Row, 4), Cells(Target.Row, 6)).ClearContents
End If
ExitSub:
Application.EnableEvents = True
Exit Sub
ErrHandler:
MsgBox "Oh Noes!", vbCritical
Resume ExitSub
End Sub
You should disable events and cater for multiple cells when using the Change event.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = Intersect(Columns("A"), Target)
If rng1 Is Nothing Then Exit Sub
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
For Each rng2 In rng1.Cells
If IsEmpty(rng2.Value) Then rng2.Offset(0, 1).Resize(1, 5).ClearContents
Next
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
For those that need to have data entered in one cell cleared (in a column) when there's a change in another column use this, which is a modification of Gary's Student.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rLook As Range, r As Range, Intr As Range
Set rLook = Range("D:D")
Set Intr = Intersect(rLook, Target)
If Intr Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Intr
If r.Value = "" Then
rw = r.Row
Range("L:L").ClearContents
End If
Next r
Application.EnableEvents = True
End Sub

Macro to check for blank cells and highlight them

I need to create a macro in Excel which could check if cell contents are not blank then I needed a border.
I have tried this macro:
Sub testborder()
Dim rRng As Range
Set rRng = Sheet1.Range("B2:D5")
'Clear existing
rRng.Borders.LineStyle = xlNone
'Apply new borders
rRng.BorderAround xlContinuous
rRng.Borders(xlInsideHorizontal).LineStyle = xlContinuous
rRng.Borders(xlInsideVertical).LineStyle = xlContinuous
End Sub
Try the following:
Sub testborder()
Dim rRng As Range, row As Range, c As Range
Set rRng = Sheet1.Range("B2:D5")
'Clear existing
rRng.Borders.LineStyle = xlNone
For Each row In rRng.Rows
For Each c In row.Columns
'Apply new borders
If (c.Value > "") Then c.BorderAround xlContinuous
Next c
Next row
End Sub
Or, with an even simpler loop:
For Each c In rRng.Cells
'Apply new borders
If (c.Value > "") Then c.BorderAround xlContinuous
Next c
You can do whatever test you want. In this example, it checks to see if there is any text in each cell, if so it puts a border around it.
Sub BorderForNonEmpty()
Dim myRange As Range
Set myRange = Sheet1.Range("B2:D5")
' Clear existing borders
myRange.Borders.LineStyle = xlLineStyleNone
' Test each cell and put a border around it if it has content
For Each myCell In myRange
If myCell.Text <> "" Then
myCell.BorderAround (xlContinuous)
End If
Next
End Sub

Resources