I have a worksheet that count the number of days between a designated date in column A and today() date in column B which stops the counting in column C if there is the word "CLOSED" in Column D. But I have a problem where I want to reapply back the formula if column D is blank again. I'm not sure how to make the column rows appear at the right place for the formula to be used
Below is the VBA code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells = "CLOSED" Then
'Run only when change is made in Column D
If Target.Column = 4 Then
Application.EnableEvents = False
'Replace the formula with the current result
Range("C" & Target.Row) = Range("C" & Target.Row).Value
Range("B" & Target.Row) = Range("B" & Target.Row).Value
Application.EnableEvents = True
End If
End If
If Target.Cells = "" Then
'Run only when change is made in Column D
If Target.Column = 4 Then
Application.EnableEvents = False
'Replace the formula with the current result
Range("C" & Target.Row).Formula = "=TRUNC($B2 - $A2)"
Range("B" & Target.Row).Value = "=Today()"
Application.EnableEvents = True
End If
End If
End Sub
I would really appreciate it if someone can teach me how to properly change the code:
Range("C" & Target.Row).Formula = "=TRUNC($B2 - $A2)"
as I am still new to VBA programming and would like to learn from my mistake
Below will do what you want. Learn that you can use the .FormulaR1C1 similar to effect of filling up/down. The potential issues including more than 1 cells is changed. Have not put checks if the cells in columns A/B are empty.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim oRng As Range
Application.EnableEvents = False
For Each oRng In Target.Cells
With oRng
If .Column = 4 Then
If UCase(Trim(.Value)) = "CLOSED" Then
.Worksheet.Cells(.Row, "B").Value = .Worksheet.Cells(.Row, "B").Value
.Worksheet.Cells(.Row, "C").Value = .Worksheet.Cells(.Row, "C").Value
ElseIf Len(Trim(.Value)) = 0 Then
.Worksheet.Cells(.Row, "B").Formula = "=Today()"
.Worksheet.Cells(.Row, "C").FormulaR1C1 = "=TRUNC(RC[-2]-RC[-3])"
End If
End If
End With
Next oRng
Application.EnableEvents = True
End Sub
My understanding is that:
you need to act for any column 4 cell change, only
there can be more than one changed cell in column 4
so I'd go like follows (explanations in comments):
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rangeToProcess As Range
Set rangeToProcess = Intersect(Target, Columns(4)) 'mind edited cells in column 4 only
If rangeToProcess Is Nothing Then Exit Sub
Dim cell As Range
Application.EnableEvents = False
For Each cell In rangeToProcess 'loop through edited cells in column 4
With cell.Offset(, -2).Resize(, 2) ' reference a 2-cells range at the left of current cell
Select Case cell.Value 'process current cell value
Case "CLOSED" ' if it's "CLOSED" ...
.Value = .Value ' ... then leave values in referenced cells
Case "" ' if it's "" ...
.FormulaR1C1 = Array("=Today()", "=TRUNC(RC[-1]-RC[-2])") ' ... then restore formulas
End Select
End With
Next
Application.EnableEvents = True
End Sub
Related
I have an excel document which has a lot of info and statistics and i am trying to figure out how to solve the following issue:
If a cell on column E, in the interval E5:E70, contains the "N/A" text (without quotes), i want to automatically input the "N/A" text on several specific cells in the same row
Added an image for reference.
Any help would be much appreciated, Thanks !
Latest edit:
I have attached a copy of the excel, maybe it will be a lot more helpful, for me it just won't work...it's so frustrating...
excel file
Paste the code below into the code sheet of the worksheet on which you want to have the action.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim C As Long
If Not Application.Intersect(Target, Range("E5:E70")) Is Nothing Then
SetApplication False
With Target
If StrComp(Trim(.Value), "N/A", vbTextCompare) = 0 Then
' recognises "n/a" as "N/A" and corrects entry
For C = Columns("E").Column To Columns("AL").Column
Cells(.Row, C).Value = "N/A"
Next C
End If
End With
SetApplication True
End If
End Sub
Private Sub SetApplication(ByVal AppMode As Boolean)
With Application
.EnableEvents = AppMode
.ScreenUpdating = AppMode
End With
End Sub
I assumed (based on the picture) that you want paste N/A's in this way: F - paste, G - don't paste, H - paste - and repeat this three further: paste, don't paste, paste, paste, don't paste, paste, etc.
So this code works accordingly to this rule. You just need to specify very last column instead of Column.Count - 2 - this bit says just that program should fill until the last column in a sheet.
Sub FillNAs()
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim i, j As Long
For i = 5 To 70
If UCase(Cells(i, 5).Value) = "N/A" Then
j = 6
Do While j < Columns.Count - 2
Cells(i, j).Value = "N/A"
Cells(i, j + 2).Value = "N/A"
j = j + 3
Loop
End If
Next i
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Try
Sub Demo()
Dim ws As Worksheet
Dim cel As Range
Set ws = ThisWorkbook.Sheets("Sheet1") 'change Sheet1 to your data sheet
For Each cel In ws.Range("E5:E70")
If CVErr(cel.Value) = CVErr(xlErrNA) Then
ws.Range("F" & cel.Row & ":I" & cel.Row) = CVErr(xlErrNA) 'mention desired range instead of (F:I)
End If
Next cel
End Sub
Is there a way to speed this code up? I need it to remove and write the same content to the cell to force other VBA code to run that's on another column. Which is what it does, just super damn slow. And there is sometimes 2000 entries/rows on this sheet. Its about 3 seconds per cell, and it almost maxes my CPU out lol. (i7 6850k # 4.4ghz).
Reason for it, is sometimes the data is copied from an old version of the spreadsheet to a new version, and the VBA updated columns wont update, unless I physically change the cell its checking.
Sub ForceUpdate()
On Error GoTo Cleanup
Application.ScreenUpdating = False ' etc..
ThisWorkbook.Sheets("Sales Entry").Unprotect "password!"
Dim cell As Range, r As Long
r = 2
For Each cell In ThisWorkbook.Sheets("Sales Entry").Range("E2:E10")
If Len(cell) > 0 Then
Dim old As String
old = cell.Value
ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = ""
ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = old
r = r + 1
End If
Next cell
Cleanup:
Application.ScreenUpdating = True ' etc..
ThisWorkbook.Sheets("Sales Entry").Protect "password!", _
AllowSorting:=True, AllowFiltering:=True
End Sub
The code in the other VBA section is
If StrComp("pp voice", Target.Value, vbTextCompare) = 0 Then
Target.Value = "PP Voice"
Target.Offset(0, 8).Value = "N\A"
Target.Offset(0, 8).Locked = True
Target.Offset(0, 10).Value = "N\A"
Target.Offset(0, 10).Locked = True
End If
Target.Value is referring to the E column in the first piece of code. At the moment I have the first piece attached to a button, but it's way to slow. And the target machines are no where near as powerful as mine.
Use application.enableevents = false and application.calculation = xlcalculationmanual. Turn them back on before exiting. You must be either triggering an large event or complex calculation cycle if it it taking 3 seconds per cell.
Change,
Dim cell As Range, r As Long
r = 2
For Each cell In ThisWorkbook.Sheets("Sales Entry").Range("E2:E10")
If Len(cell) > 0 Then
Dim old As String
old = cell.Value
ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = ""
ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = old
r = r + 1
End If
Next cell
... to,
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim cell As Range
With ThisWorkbook.Sheets("Sales Entry")
For Each cell In .Range("E2:E10")
If CBool(Len(cell.Value2)) Then
cell = cell.Value2
End If
Next cell
End With
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Try this
Option Explicit
Sub ForceUpdate()
On Error GoTo Cleanup
Dim SalesEntrySheet As Worksheet
Set SalesEntrySheet = ThisWorkbook.Sheets("Sales Entry")
Application.ScreenUpdating = False ' etc..
SalesEntrySheet.Unprotect "password!"
Dim cell As Range, r As Long
Dim ArrayPos As Long
Dim SalesEntrySheetArray As Variant
With SalesEntrySheet
'Starting with row one into the array to ease up the referencing _
so Array entry 2 will be for row 2
SalesEntrySheetArray = .Range("E1:E" & .Cells(.Rows.Count, "E").End(xlUp).Row)
'Clearing the used range in Col E
'If you are using a WorkSheet_Change for the second part of your code then you should rather make this a loop
.Range("E1:E" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value = ""
'Putting the values back into the sheet
For ArrayPos = 2 To UBound(SalesEntrySheetArray, 1)
.Cells(ArrayPos, "E").Value = SalesEntrySheetArray(ArrayPos, 1)
Next ArrayPos
End With
Cleanup:
Application.ScreenUpdating = True ' etc..
ThisWorkbook.Sheets("Sales Entry").Protect "password!", AllowSorting:=True, _
AllowFiltering:=True
End Sub
Try to use with statement.
and take a look at Optimizing VBA macro
Sub ForceUpdate()
On Error GoTo Cleanup
Application.ScreenUpdating = False ' etc..
ThisWorkbook.Sheets("Sales Entry").Unprotect "password!"
Dim cell As Range, r As Long
r = 2
With ThisWorkbook.Sheets("Sales Entry")
For Each cell In .Range("E2:E10")
If Len(cell) > 0 Then
Dim old As String
old = cell.Value
.Cells(4, r) = ""
.Cells(4, r) = old
r = r + 1
End If
Next cell
End With
Cleanup:
Application.ScreenUpdating = True ' etc..
ThisWorkbook.Sheets("Sales Entry").Protect "password!", AllowSorting:=True, AllowFiltering:=True
End Sub
I have Worksheet_Change code in my Excel worksheet. If there is a change in a given column it should add the date and time (from Now()) to a corresponding cell in a different column.
This sub should check two places and depending on which range was changed should update a different cell. If column G changes, update column A; if column K changes, update column M.
I'm not getting any errors. The date and time aren't being added to the corresponding cell.
It worked a few days ago.
Private Sub Worksheet_Change(ByVal Target As range)
Dim cell As range
'Adds unique keyA values
'Check to see if the changed cell is in column G
If Not Intersect(Target, range("G:G")) Is Nothing Then
For Each cell In Target.Cells
If cell.Value <> vbNullString And Target.Row > 7 And Target.Row <= 20 Then
'Update the "KeyA" value
sheets("Front End").range("A" & Target.Row).Value = Now()
End If
Next cell
Else
'Adds unique keyB values
'Check to see if the changed cell is in column K
If Not Intersect(Target, range("K:K")) Is Nothing Then
For Each cell In Target.Cells
If cell.Value <> vbNullString And (Target.Row > "7" And Target.Row <= "27") Then
'Update the "KeyM" value
sheets("Front End").range("M" & Target.Row).Value = Now()
End If
Next cell
End If
End If
End Sub
The code that changes the value in row G is called by a button:
Private Sub CommandButton1_Click()
Sheets("Front End").Unprotect ("29745")
h = Hour(Now)
For Each c In range("B8:B20")
If h = Hour(c) Then
c.Offset(0, 3) = CInt(c.Offset(0, 3)) + 1
Exit For
End If
Next c
Sheets("Front End").Protect ("29745")
Unload Me
End Sub
Probably you are trying to achieve something like this:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cell As Range
'Adds unique keyA values
'Check to see if the changed cell is in column G
If Not Intersect(Target, Range("G:G")) Is Nothing Then
For Each cell In Target.Cells
If cell.Value <> vbNullString And Target.Row > 7 And Target.Row <= 20 Then
'Update the "KeyA" value
Range("A" & Target.Row).Value = Now()
End If
Next cell
Else
'Adds unique keyB values
'Check to see if the changed cell is in column K
If Not Intersect(Target, Range("K:K")) Is Nothing Then
For Each cell In Target.Cells
If cell.Value <> vbNullString And (Target.Row > "6" And Target.Row <= "27") Then
'Update the "KeyM" value
Range("M" & Target.Row).Value = Now()
End If
Next cell
End If
End If
End Sub
Worksheet_Change is not Selection_Change.
Dont put it in a module, rather double click on the worksheet in the left hand pane when you launch developer. Module wont' work for private subs.
I could use some assistance correcting the code below as what show when activated is the first image while I want to do the second image.
Also if you have other code to do the same job, please do. thanks in advance for your assistance.
Private Sub Worksheet_Activate()
Dim rng As Range, cell As Range
Dim a As Range, az As Range
Application.EnableEvents = False
Set rng = Range("A2:AE2")
Set az = Range("A3:AE6")
For Each cell In rng
For Each a In az
If cell.Value = "Fri" Then
a.Value = "Fri"
ElseIf cell.Value = "Sat" Then
a.Value = "Sat"
End If
Next a
Next cell
Application.EnableEvents = True
End Sub
Use the { and the } in the styling/headers section, above where you type, to insert formatted code next time please so that it looks like this. :)
Edited with your answer:
Private Sub Worksheet_Activate()
Dim rng As Range, cell As Range
Dim a As Range, az As Long 'set az = number of rows you want filled with fri/sat
Application.EnableEvents = False
Set rng = Range("A2:AE2")
az = 4
For Each cell In rng
If cell.Value = "fri" Then
For i = 1 To az
cell.Offset(i).Value = "fri"
Next i
ElseIf cell.Value = "sat" Then
For i = 1 To az
cell.Offset(i).Value = "sat"
Next i
End If
Next cell
Application.EnableEvents = True
End Sub
You get the result because you do it for each cell in az, but you dont wan't to do it so, you have to fill just the column of the found Fri or Sat.
Private Sub Worksheet_Activate()
Dim rng As Range, cell As Range
Application.EnableEvents = False
Set rng = Range("B2:BE2")
For Each cell In rng
If cell.value = "Fri" Then
For i as Integer = 3 To 6 Step 1
Cells(i,cell.column).Value = "Fri"
Next
End If
If cells.value = "Sat" Then
For i as Integer = 3 To 6 Step 1
Cells(i,cell.column).Value = "Sat"
Next
End If
Next cell
Application.EnableEvents = True
End Sub
It should be something like that i think
Also if you have other code to do the same job, please do.
The following will ask to build a new calendar worksheet based upon the current month every time you create a new worksheet.
ThisWorkbook code sheet:
Option Explicit
Private Sub Workbook_NewSheet(ByVal Sh As Object)
If MsgBox("Create new calendar?", vbYesNo, "AutoBuild") <> vbYes Then Exit Sub
'the following DELETES ANY WORKSHEET WITH THE SAME MONTH/YEAR NAME
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(Format(Date, "mmm yyyy")).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'create a new calendar worksheet based on the current month
With Sh
Dim c As Long
.Name = Format(Date, "mmm yyyy")
With .Cells(1, 1).Resize(6, Day(DateSerial(Year(Date), Month(Date) + 1, 0)))
.Formula = "=DATE(" & Year(Date) & ", " & Month(Date) & ", COLUMN())"
.Value = .Value
.Rows(1).NumberFormat = "d"
.Rows(2).Resize(.Rows.Count - 1, .Columns.Count).NumberFormat = "ddd"
.EntireColumn.ColumnWidth = 5 'AutoFit
.HorizontalAlignment = xlCenter
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
With .FormatConditions
.Delete
.Add Type:=xlExpression, Formula1:="=AND(ROW()>2, WEEKDAY(A2, 15)>2)"
.Add Type:=xlExpression, Formula1:="=WEEKDAY(A2, 15)<3"
.Add Type:=xlExpression, Formula1:="=AND(ROW()=2, WEEKDAY(A2, 15)>2)"
End With
.FormatConditions(1).NumberFormat = ";;;"
.FormatConditions(2).Interior.Color = 5287936
.FormatConditions(3).Interior.Color = 14281213
End With
End With
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
.Zoom = 80
End With
End With
End Sub
You will likely want to make adjustments but this may be a good framework to get started. I've taken the approach of using the actual dates and displying their day-of-the-month and day-of-the-week through cell Number Format Codes. This leaves the raw underlying date value(s) available for calculation and lookup. Similarly, the dates that appear blank are not actually blank; the custom number format that has been applied through Conditional Formatting simply shows no value at all in the cell.
I've found an answer to part of the question, but I need help to complete the code as it applies to one row only.
Private Sub Worksheet_Activate()
Dim cell As Range, rng As Range
Application.EnableEvents = False
Set rng = Range("A2:AE2")
For Each cell In rng
If Cells(2, cell.Column) = "Fri" Then
Cells(3, cell.Column) = "Fri"
ElseIf Cells(2, cell.Column) = "Sat" Then
Cells(3, cell.Column) = "Sat"
End If
Next cell
Application.EnableEvents = True
End Sub
This is my first time to write a code and i try to write a code thats helps me to fill Columns B, C and D Automatically thats will happen when i fill Column A by myself.
this is the picture of that sheet i work on it now
Worksheet Explaining what i Want
The final result must be like this Picture
i try to google the code and i found a code but it not work at all
This is the first code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
r.Offset(0, 1).Value = Date
Next r
Application.EnableEvents = True
End Sub
also i try to write another code thats may helps me to fill Column B and C based on above code results but still not work.
This is the code written by me
Private Sub Worksheet_Change1(ByVal Target As Range)
Dim i As Integer
For i = 6 To 1000
If Cells(i, "A").Value <> "" And Cells(i, "B").Value <> "" Then
Cells(i, "C").Value = Date
Cells(i, "C").NumberFormat = "mmm"
Cells(i, "D").Value = Date
Cells(i, "D").NumberFormat = "yyyy"
End If
Next
Range("C:C").EntireColumn.AutoFit
Range("D:D").EntireColumn.AutoFit
End Sub
anyone can help with that?
The Worksheet_Change event macro is triggered when one or more cells on the worksheet changes value. If you write values into the worksheet within the Worksheet_Change procedure (like you are with the dates) without first turning off event handling then another Worksheet_Change is triggered and the procedure tries to run on top of itself. Always turn off event handling with Application.EnableEvents = False before writing values to the worksheet.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:B")) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
Dim rw As Long, rng As Range
For Each rng In Intersect(Target, Range("A:B"))
If Application.CountA(Cells(rng.Row, "A").Resize(1, 2)) = 2 Then
Cells(rng.Row, "C").Resize(1, 2).Value = Date
Cells(rng.Row, "C").NumberFormat = "mmmm"
Cells(rng.Row, "D").NumberFormat = "yyyy"
End If
Next rng
Range("C:C").EntireColumn.AutoFit
Range("D:D").EntireColumn.AutoFit
End If
bm_Safe_Exit:
If CBool(Val(Err.Number)) Then _
Debug.Print Err.Number & ": " & Err.Description
Application.EnableEvents = True
End Sub
Remember to turn events back on with Application.EnableEvents = True before exiting the Worksheet_Change procedure or future value changes will not trigger the Worksheet_Change procedure again.
btw, the correct number format for October is mmmm, not mmm. The former gives the full month name; the latter only the three letter abbreviation (e.g. Oct).