How do you make VBA run on multiple cells? - excel

I am very new to VBA but pretty good at formulas. I am working on a time stamp issue. I have the code written so that if I choose from a validation list in E3 it will give me a time stamp in F3. I want this to be true of all cells in the E column starting with E3. I will have between 500 and 15000 records (rows). The code I am using is pasted below. Thanks in advance for any suggestions.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 5 And Target.Row = 3 Then
If Target.Value = "" Then
Cells(3, 6).Value = ""
Else
Cells(3, 6).Value = Format(Now, "mm/dd/yyyy HH:mm:ss")
End If
End If
End Sub

How's this?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 5 And Target.Row >= 3 Then
i = Target.Row
If Target.Value = "" Then
Cells(i, 6).Value = ""
Else
Cells(i, 6).Value = Format(Now, "mm/dd/yyyy HH:mm:ss")
End If
End If
End Sub

The fastest way to do this is to select the entire range a set the value once using an array. This is done with the .Value property of a Range when it contains multiple cells.
Private Sub SetDate(ByVal Target As Range, Optional bybal RowCount as Long = 0)
Dim i as Long
' Check if row count needs to be found
If RowCount = 0 Then
'Count non-empty rows from target down
RowCount = Target.Worksheet.Range(Target, Target.End(xlDown).Rows.Count
End If
' Target entire range of cells that are going to be affected
Set Target = Target.Resize(RowCount, 6)
Dim vals() as Variant
' Read values from worksheet
vals = Target.Values
' Make changes in memory here
For i=1 to RowCount
if IsEmpty(vals(i,1)) Then
vals(i, 6) = vbNullString
Else
vals(i, 6) = Format(Now, "mm/dd/yyyy HH:mm:ss")
End If
Next i
' Write values into worksheet
Target.Value = vals
End Sub

Related

Setting Excel cell value based on another cell value using VBA

I have the following spreadsheet. When ever there is an x in cell B I need to populate the d and e cells in the same row using an equation I have.
if there is no x in the b cell I need to manually enter values into cells d & e.
How do I make my code non-row specific?
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim val As String
val = Range("B3").Value
If val = "x" Then
Range("E3").Value = Range("d2").Value * Range("G2").Value
Range("D3").Value = Range("D2").Value
End If
End Sub
I'm not sure if I understand correctly, but if you have a parameter: row = 3 you can use Range("E" & row) instead of Range("E3").
Put a loop around that where you vary 'row' for the rows you want to modify.
Hope that helps!
You've created a sub procedure around the Worksheet_SelectionChange event. In fact, you require Worksheet_Change and you need to,
disable event handling so you can write new values/formulas to the worksheet without running the Worksheet_Change on top of itself.
loop through each matching cell in Target to compensate for circumstances when Target can be more than a single cell,
add error control.
Rewrite:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B:B")) Is Nothing Then
On Error GoTo safe_exit
Application.EnableEvents = False
Dim t As Range
For Each t In Intersect(Target, Range("B:B"))
If LCase(t.Value) = "x" Then
'I've made these formulas relative to each target
'you may want to make some absolute references
t.Offset(0, 3) = t.Offset(-1, 2) * t.Offset(-1, 5)
t.Offset(0, 2) = t.Offset(-1, 2)
Else
t.Offset(0, 2).resize(1, 2) = vbnullstring
End If
Next t
End If
safe_exit:
Application.EnableEvents = True
End Sub
Please try below code.
It loop through all non empty rows in column B and check if there is value: x
If so it populate your formulas.
Sub new_sub()
' get last_row of data
last_row = ActiveSheet.UsedRange.Rows.Count
' loop through all rows with data and check if in column B any cell contains value: x
For i = 1 To last_row
' if there is any cell with value: x
' then add below formulas
If Cells(i, 2).Value = "x" Then
' for column E: take value from row above for col D and G and multiple
Range("E" & i).Value = Range("d" & i - 1).Value * Range("G" & i - 1).Value
' for column D: take value from row above
Range("D" & i).Value = Range("D" & i - 1).Value
End If
Next i
End Sub

Updating sheet automatically when a change is made - VBA Excel

I struggling to work out the logic to this so any help would be appreciated!
I have a sheet with names and dates, on each row (in the example column D to F) it needs to find the greatest date and then add a date to a column (column C). I can get this to work on a single test row, but I need it to work when there is a change on any row.
B C D E F
Name Due Date Date 1 Date 2 Date 3
Dave 01-01-20 01-01-14 01-01-17
Sarah 01-01-21 01-02-11 01-02-15 01-02-18
The code I have so far is:
LastRow = wsCB.Cells(Rows.Count, "C").End(xlUp).Row
rowcount = 12
Max_date = Application.WorksheetFunction.Max(wsCB.Range(wsCB.Cells(rowcount, 5), wsCB.Cells(rowcount, 10)))
Max_date = CDate(Max_date)
DueDate = DateAdd("yyyy", 3, Max_date)
wsCB.Cells(12, 4) = DueDate
I have set it to call on a Worksheet_Change. I have tried various loops trying to use xlup but I'm not sure this is the right way to go about it as I need the value to be updated when the user has typed in a new date for someone. I can't quite work out how to scale this single line example to the whole sheet.
The data won't be massive, however there will be 5 sheets like this with up to a maximum of 70 names on each sheet.
I'm still quite new to VBA so any advice would be very helpful!
The following VBA code should achieve your desired results:
Private Sub Worksheet_Change(ByVal Target As Range)
Select Case Target.Column
Case 4, 5, 6 'if user entered data in columns D to F
Max_date = Application.WorksheetFunction.Max(Range(Cells(Target.Row, 4), Cells(Target.Row, 6)))
'get the max value in row from column D to F (4 to 6)
Max_date = CDate(Max_date)
DueDate = DateAdd("yyyy", 3, Max_date)
Cells(Target.Row, 3) = DueDate
End Select
End Sub
Try this.
You'll just need to adjust columns to fit your needs
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MaxDate As Date, DueDate As Date
Dim CurRow As Long
Dim Ws As Worksheet
Set Ws = Target.Parent
CurRow = Target.Row
With Ws
MaxDate = CDate(Application.WorksheetFunction.Max(.Range(.Cells(CurRow, "D"),.Cells(CurRow, "F"))))
DueDate = DateAdd("yyyy", 3, MaxDate)
Application.EnableEvents = False
.Cells(CurRow, 3) = DueDate
Application.EnableEvents = True
End With
End Sub
My suggested code for your problem:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xCellColumnD As Long
Dim xCellColumnE As Long
Dim xCellColumnF As Long
Dim xDueColumn As Long
Dim xRow As Long, xCol As Long
xCellColumnD = 4
xCellColumnE = 5
xCellColumnF = 6
xDueColumn = 3
xRow = Target.Row
xCol = Target.Column
If Target.Text <> "" Then
If xCol = xCellColumnD Or xCol = xCellColumnE Or xCol = xCellColumnF Then
Max_date = Application.WorksheetFunction.Max(Range(Cells(xRow, 4), Cells(xRow, 6)))
Max_date = CDate(Max_date)
DueDate = DateAdd("yyyy", 3, Max_date)
Cells(xRow, xDueColumn) = DueDate
End If
End If
End Sub
I suggest to use Intersect in combination with a loop over the Target range so you are a bit more save against pasting a whole range of values.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = Target.Parent
If Not Intersect(Target, ws.Range("D:F")) Is Nothing Then
Dim MaxDate As Double
Dim DueDate As Variant
Dim iRow As Long
For iRow = Target.Row To Target.Row + Target.Rows.Count - 1
On Error Resume Next
MaxDate = Application.WorksheetFunction.Max(ws.Range(ws.Cells(iRow, "D"), ws.Cells(iRow, "F")))
If Err.Number <> 0 Then
DueDate = "#VALUE!"
ElseIf MaxDate = 0 Then
DueDate = vbNullString 'remove date if no dates
Else
DueDate = DateAdd("yyyy", 3, MaxDate)
End If
On Error GoTo 0
Application.EnableEvents = False 'prevents triggering change event again
ws.Cells(iRow, "C").Value = DueDate
Application.EnableEvents = True
Next iRow
End If
End Sub

Automatically adding a month-summery row at the end of each month?

I'm using an excel sheet to track my working hours. Each row represents a working day and has "date", "time in", "time out", "total working hours", and "daily salary".
I'd like the sheet to automatically create a month summery line every time I write an entry in the next month (i.e if a row with the date 13/3/16 is followed by a row with the date 2/4/16, the second row will be pushed down, and a row with the summery (i.e: total monthly hours, total monthly salary) will be created in between. it should look something like that:
Is that possible? if so, how do I do it?
Thank you for your input!
You should place this code in Sheet Code Module. It worked for me on data organized like your.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ThisSheet As Worksheet
Dim NewRow As Long
Dim OldTotalRange As Range
Dim OldTotalRow As Long
Set ThisSheet = ActiveSheet
'If not single cell is changed, exit sub
If Target.Cells.Count = 1 Then
'Disable events for prevent recursion
Application.EnableEvents = False
If Target.Column = 1 And Target.Row <> 1 And Target.value <> "" Then
If IsDate(Target.value) And IsDate(Target.Offset(-1, 0).value) Then
If Month(Target.value) <> Month(Target.Offset(-1, 0).value) Then
With ThisSheet
NewRow = Target.Row
On Error Resume Next
Set OldTotalRange = .Columns(1).Find(What:="Total", After:=Target, SearchDirection:=xlPrevious)
OldTotalRow = OldTotalRange.Row
'It's for first 'Total' when there isn't 'totals' before.
If OldTotalRow = 0 Then
OldTotalRow = 1
End If
.Rows(NewRow).Insert
.Cells(NewRow, 1) = "Total"
.Cells(NewRow, 4).FormulaR1C1 = "=SUM(R[-" & NewRow - OldTotalRow - 1 & "]C:R[-1]C)"
.Cells(NewRow, 5).FormulaR1C1 = "=SUM(R[-" & NewRow - OldTotalRow - 1 & "]C:R[-1]C)"
'It's formatting, you can delete it or change
.Range(.Cells(NewRow, 1), .Cells(NewRow, 5)).Interior.Color = RGB(196, 215, 155)
.Range(.Cells(NewRow, 1), .Cells(NewRow, 5)).Font.Bold = True
End With
End If
End If
End If
Else
Exit Sub
End If
'Enable events
Application.EnableEvents = True
End Sub

running an excel macro that compares selected cells

I want to run a macro on selected cells - where the macro compares a cell to it's neighbor beneath him - changes their color and moves on to the next pair of cells.
it's A 1 dimension array where I want to compare each pair of cells (1st with the 2nd, 3rd with the 4th etc.)
I tried working with
For Each cell In Selection
but then I don't know how to compare the given cell to the one beneath it.
Below is the sample code.
Sub compare()
Dim rng As Range, cell As Range
Set rng = Selection '
For Each cell In rng
'makes comparison
'offset(1,0) is used to find one cell below active cell
If cell.Value = cell.Offset(1, 0) Then
cell.Offset(1, 0).Interior.Color = vbRed
End If
Next
End Sub
Updated answer
Sub compare()
Dim rows As Long
rows = Selection.rows.Count - 1
Dim selCol As Long
selCol = ActiveCell.Column
Dim selRow As Long
selRow = ActiveCell.Row
For i = selRow To (selRow + rows)
If Cells(i, selCol) = Cells(i, selCol + 1) Then
Range(Cells(i, selCol), Cells(i, selCol + 1)).Interior.Color = vbYellow
End If
Next
End Sub
Sub compareCells()
Dim i As Integer
'Check dimension
If Selection.Columns.Count <> 1 Then
MsgBox "not 1d array"
Exit Sub
End If
'Check size
If Selection.Rows.Count Mod 2 <> 0 Then
MsgBox "size not even"
Exit Sub
End If
For i = 1 To Selection.Count / 2
With Selection
If .Cells(2 * i - 1) = .Cells(2 * i) Then
'what you want to do here, for e.g. , change color
.Cells(2 * i).Interior.Color = vbYellow
Else
'what you want to do here
'MsgBox "neq"
End If
End With
Next i
End Sub

How to run VBA code when cell contents are changed via formula

The code below works fine when I manually update column I. What I need is to know if there is a way to still have this code work when I have column I updated by a formula.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("I3:I30"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, -1).ClearContents
Else
With .Offset(0, -1)
.NumberFormat = "m/d/yy h:mm"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
End Sub
Worksheet_Change does not fire in responce to a formula update.
See Excel help for Worksheet_Change
Occurs when cells on the worksheet are changed by the user or by an external link.
You could maybe achieve what you want with the Worksheet_Calculate event.
Assuming you want to put a time stamp next to the cells when those vall values change, try this (in addition to your Change event).
Note the use of the Static variable to track previous values, since Calculate event does nopt provide a Target parameter like Change does. This method may not be robust enough since Static's get reset if you break vba execution (eg on an unhandled error). If you want it more robust, consider saving previous values on another (hidden) sheet.
Private Sub Worksheet_Calculate()
Dim rng As Range, cl As Range
Static OldData As Variant
Application.EnableEvents = False
Set rng = Me.Range("I3:I30")
If IsEmpty(OldData) Then
OldData = rng.Value
End If
For Each cl In rng.Cells
If Len(cl) = 0 Then
cl.Offset(0, -1).ClearContents
Else
If cl.Value <> OldData(cl.Row - rng.Row + 1, 1) Then
With cl.Offset(0, -1)
.NumberFormat = "m/d/yy h:mm:ss"
.Value = Now
End With
End If
End If
Next
OldData = rng.Value
Application.EnableEvents = True
End Sub
Update
Tested routine on sample sheet, all works as expected
Sample file contains the same code repeated on 25 sheets, and range to time stamp is 10000 rows long.
To avoid repeating the code, use the Workbook_ events. To minimise run time use variant arrays for the loop.
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Dim rng As Range
Dim NewData As Variant
Dim i As Long
Static OldData As Variant
Application.EnableEvents = False
Set rng = Sh.Range("B2:C10000") ' <-- notice range includes date column
NewData = rng
If IsEmpty(OldData) Then
OldData = rng.Value
End If
For i = LBound(NewData, 1) To UBound(NewData, 1)
If Len(NewData(i, 1)) = 0 And Len(NewData(i, 2)) > 0 Then
rng.Cells(i, 2).ClearContents
Else
If NewData(i, 1) <> OldData(i, 1) Then
With rng.Cells(i, 2)
.NumberFormat = "m/d/yy -- h:mm:ss"
.Value = Now
End With
End If
End If
Next
OldData = rng.Value
Application.EnableEvents = True
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'Activate date population on cell change
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Sh.Range("B2:B10000"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, 1).ClearContents
Else
'Populate date and time in column c
With .Offset(0, 1)
.NumberFormat = "mm/dd/yyyy -- hh:mm:ss"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
End Sub

Resources