Check values in a range before continuing - vba

So right now I have an excel workbook for a task tracker. When the column that contains the completed date is filled in, it will take that row and copy it onto another sheet ("Complete") then delete it off the current sheet ("Current"). What I would like it to do before this is executed is check the values of columns H through M for either a "C" or "U". If any of the Cells in that range do not contain either or, then I want it to exit out and display a message. I am not to familiar with Excel or VBA, but decent with C++.
Here is the code as of right now:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim receivedDate As Range, nextOpen As Range, isect As Range
Set receivedDate = Sheet1.Range("G3:G166")
Set isect = Application.Intersect(Target, receivedDate)
If Not (isect Is Nothing) And IsDate(Target) = True Then
Set nextOpen = Sheet4.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Target.EntireRow.Copy Destination:=nextOpen.EntireRow
Target.EntireRow.Delete
End If
Application.EnableEvents = True
End Sub
Here is snip of what I have going on...
snip of work
Any help would be greatly appreciated. Sorry I tried looking around some.

Edit - more robust, added error handler and multi-cell update handling
Private Sub Worksheet_Change(ByVal Target As Range)
Dim receivedDate As Range, nextOpen As Range, isect As Range
Dim rngHM As Range, c As Range, rngDel As Range
Set receivedDate = Sheet1.Range("G3:G166")
'are any of the changed cells in the range we're monitoring?
Set isect = Application.Intersect(Target, receivedDate)
On Error GoTo haveError 'error handler ensures events get re-enabled...
'### remember that Target can contain >1 cell...
For Each c In isect.Cells
If IsDate(c.Value) Then
With c.EntireRow
Set rngHM = .Cells(1, "H").Resize(1, 6)
'EDIT: all cells must be C or U
If (Application.CountIf(rngHM, "C") + _
Application.CountIf(rngHM, "U")) <> rngHM.Cells.Count Then
MsgBox "No C or U on row " & c.Row & " !"
Else
Set nextOpen = Sheet4.Range("A" & Rows.Count) _
.End(xlUp).Offset(1, 0)
.Copy Destination:=nextOpen.EntireRow
'deleting rows while looping gives odd results,
' so store them up until done...
If rngDel Is Nothing Then
Set rngDel = c
Else
Set rngDel = Application.Union(rngDel, c)
End If
End If
End With 'entirerow
End If 'is date
Next c
'delete any copied rows in a single operation
If Not rngDel Is Nothing Then
Application.EnableEvents = False
rngDel.EntireRow.Delete
Application.EnableEvents = True
End If
Exit Sub
haveError:
'if your code errors out then this makes sure event handling gets reset
Application.EnableEvents = True
End Sub

Related

Excel VBA to insert duplicate row below based on drop down menu

I would like to add to the following VBA code, so that when "Did not attend" is selected from dropdown menu a duplicate row is ALSO inserted below the current row within the current worksheet "Details".
Private Sub Worksheet_Change1(ByVal Target As Range)
'Determine if change was made to a single cell in Column E
If Target.Column = 5 And Target.Cells.Count = 1 Then
'Determine if Did not attend was chosen
If Target = "Did not attend" Then
'If Yes...
''Disable Events
Application.EnableEvents = False
''Insert a row below
ActiveCell.Offset(1).EntireRow.Insert
''Copy, Paste
Rows(Target.Row).EntireRow.Copy _
Destination:=Sheets("Non Attendance").Range("A" & nxtRw)
''Re-enable Events
Application.EnableEvents = True
End If
End If
End Sub
This code should do what you want. Please try it.
Private Sub Worksheet_Change(ByVal Target As Range)
' 22 Jan 2018
Dim Rng As Range
Set Rng = Range(Cells(2, "E"), Cells(Rows.Count, "E").End(xlUp))
Debug.Print Target.Address
' Determine if change was made in Column E, below row 1 and above last row
If Not Application.Intersect(Target, Rng) Is Nothing Then
With Target
On Error Resume Next
If .Cells.Count = 1 Then ' if change was in a single cell
'Determine if Did not attend was chosen
If StrComp(.Value, "Did not attend", vbTextCompare) = 0 Then
' If Yes...
Application.EnableEvents = False
.Offset(1).EntireRow.Insert ' Insert a row below
With Worksheets("Non Attendance")
Set Rng = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
End With
' Copy, Paste
Rows(.Row).EntireRow.Copy Destination:=Rng
Application.EnableEvents = True
End If
End If
End With
End If
End Sub

Applying formula with changing row position to VBA

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

Having Trouble creating a valid exit condition with Excel VBA

First post all, so forgive any syntax errors: I've been working on a spreadsheet at work for a long time. Its purpose is to log my calls, as I work in a high volume inbound guest services call center. Sometimes I need to follow up with my guests.
Worksheet is Column A:K, starting at Row 5
Ultimately I'm coding a program to check my records, ignore any row that has data in Column K, then when it finds valid data, copy the records to another sheet, and come back to the main sheet. That part works fine and here is the code for that:
Sub Button2_Click()
Dim sourceEmptyRow As Long
Dim targetEmptyRow As Long
Dim sourceRange As Range
Dim targetRange As Range
'Make Today active
Sheet1.Activate
'Set Variables
sourceEmptyRow = FindNextEmpty(Range("K5")).Row
Set sourceRange = Rows(sourceEmptyRow)
sourceRange.Copy
'Activate Next Sheet
sheetQ4.Activate
'Set Variables
targetEmptyRow = FindNextEmpty(Range("A1")).Row
Set targetRange = Rows(targetEmptyRow)
targetRange.PasteSpecial
Sheet1.Activate
sourceRange.Delete Shift:=xlUp
End Sub
Here is the FindNextEmpty() function (which I'm pretty sure I found here)
Public Function FindNextEmpty(ByVal rCell As Range) As Range
'Finds the first empty cell downwards in a column.
On Error GoTo ErrorHandle
With rCell
'If the start cell is empty it is the first empty cell.
If Len(.Formula) = 0 Then
Set FindNextEmpty = rCell
'If the cell just below is empty
ElseIf Len(.Offset(1, 0).Formula) = 0 Then
Set FindNextEmpty = .Offset(1, 0)
Else
'Finds the last cell with content.
'.End(xlDown) is like pressing CTRL + arrow down.
Set FindNextEmpty = .End(xlDown).Offset(1, 0)
End If
End With
Exit Function
ErrorHandle:
MsgBox Err.Description & ", Function FindNextEmpty."
End Function
My PROBLEM is that I'd like to be able to execute this code block, then when its done, check the next row...if BOTH Column A and K are blank to STOP, otherwise Loop back to the top and execute it on the next row. If I have a long day, I can sometimes get 20-30 calls and pushing a button 20-30 times is not efficient.
I have not SERIOUSLY coded since about 2003, so I'm an EXTREME novice.
Thanks for any help, ideas, insight you can provide.
Here is my Spreadsheet
This uses the AutoFilter
Option Explicit
Public Sub MoveCompleted()
Const COL_K = 11
Const TOP_ROW = 5
Dim ws1 As Worksheet: Set ws1 = sheetToday '<--- Source sheet
Dim ws2 As Worksheet: Set ws2 = sheetQ118 '<--- Destination sheet
Dim maxRows As Long, ws1ur As Range
optimizeXL True
With ws1.UsedRange
If ws1.AutoFilterMode Then .AutoFilter
maxRows = .Rows.Count
.Offset(TOP_ROW - 2).Resize(maxRows - (TOP_ROW - 2)).AutoFilter 'ur + header row
.AutoFilter Field:=COL_K, Criteria1:="=" 'show only blanks in K
Set ws1ur = .Offset(TOP_ROW - 1).Resize(maxRows - TOP_ROW + 1, .Columns.Count)
On Error Resume Next
Set ws1ur = ws1ur.SpecialCells(xlCellTypeVisible)
If Err.Number <> 0 Then
Err.Clear
Else
ws1ur.Copy ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
ws1ur.EntireRow.Delete
End If
On Error GoTo 0
.AutoFilter Field:=COL_K
End With
optimizeXL False
End Sub
Public Sub optimizeXL(Optional ByVal settingsOff As Boolean = True)
With Application
.ScreenUpdating = Not settingsOff
.Calculation = IIf(settingsOff, xlCalculationManual, xlCalculationAutomatic)
.EnableEvents = Not settingsOff
End With
End Sub
Initial test sheets
Sheet1
sheetQ4
Result
Sheet1
sheetQ4

VBA Excel - How to Automatically Fill a date in multi-columns if i filled column A

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).

Creating a Timestamp VBA

Need Help with this Macro:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 Then
Application.EnableEvents = False
Cells(Target.Row, 3).Value = Date + Time
Application.EnableEvents = True
End If
End Sub
Sub DeleteCells()
For Each Cell In Range("B3:B25")
If IsBlank(Cell.Value) Then
Cell.Offset(0, 1).Clear
End If
Next
End Sub
The purpose of this macro is to create a timestamp. First macro works fine. If anything from row B is filled in, a timestamp will be created in row C. However, the delete cells function isn't working. I want it so that if someone deletes a cell in row B, the timestamp will also be deleted.
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range
'anything in ColB?
Set rng = Application.Intersect(Me.Columns(2), Target)
If rng Is Nothing Then Exit Sub 'nothing to process...
Application.EnableEvents = False
'could be >1 cell, so loop over them...
For Each c In rng.Cells
'skip any cells with errors
If c.Row>=3 And Not IsError(c.Value) Then '<<edit
c.EntireRow.Cells(3).Value = _
IIf(Len(c.Value) > 0, Now, "")
End If
Next c
Application.EnableEvents = True
End Sub