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
Related
Advice would be gratefully appreciated. I am developing a spreadsheet using Excel 2016/Windows.
I have written 4 eventchange subroutines and all work well. The VBA Code for a worksheet checks for 4 events. Event 1, 2 and 3 enter today's date in a cell if data is entered in another cell (code not included below)
Code for EventChange works fine, but sometimes works when not expected to!
EventChange4 moves a value from one cell to another if another cell contains the text in Column J is "THIS Month – Payment Due" or "Issued But Not Paid. The second part of this eventchange4 moves a zero value to 2 cells if the data in column j contains text "not going ahead"
I am new to VBA. The problem is that eventchange4 runs for no apparent reason, e.g. copying a cell value in column H down to another cell in column h. How can I modify the code such that that eventchange4 only runs when the data in Column J Changes??? All advice gratefully accepted!!!!
Private Sub Worksheet_Change(ByVal Target As Range)
Call EventChange_1(Target)
Call EventChange_2(Target)
Call EventChange_3(Target)
Call EventChange_4(Target)
End Sub
Sub EventChange_1(ByVal Target As Range)
'Update on 11/11/2019 -If data changes in column L, insert
'today's date into column M
End Sub
Sub EventChange_2(ByVal Target As Range)
'Update on 15/01/2020 -If data changes in column P, insert today's date
'into next Column Q
End Sub
Sub EventChange_3(ByVal Target As Range)
'Update on 15/01/2020 -If data changes in column R, insert today's date
'into next Column S
End Sub
Sub EventChange_4(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
' this works !
If Target.Column = 10 And (Target.Value = "THIS Month – Payment Due" Or Target.Value = "Issued But Not Paid") Then
Range("K" & Target.Row).Value = Range("I" & Target.Row).Value
Range("I" & Target.Row).Clear
MsgBox "Moved Commission Due to Month Paid"
End If
If Target.Column = 10 And (Target.Value = "Not Going Ahead") Then
Range("I" & Target.Row).Value = 0
Range("K" & Target.Row).Value = 0
MsgBox "Moved ZERO to Initial Commisson and Month Paid"
End If
Application.EnableEvents = True
End Sub
Ideally you should update your code so it can properly handle a Target range which is not just a single cell:
Sub EventChange_4(ByVal Target As Range)
Dim rng As Range, c As Range, v
'any part of Target in Column J?
Set rng = Application.Intersect(Target, Me.Columns(10))
If Not rng Is Nothing Then
'have some cells to process...
On Error GoTo haveError
Application.EnableEvents = False
'process each affected cell in Col J
For Each c In rng.Cells
v = c.Value
If v = "THIS Month – Payment Due" Or v = "Issued But Not Paid" Then
Range("K" & c.Row).Value = Range("I" & c.Row).Value
Range("I" & c.Row).Clear
MsgBox "Moved Commission Due to Month Paid"
End If
If v = "Not Going Ahead" Then
Range("I" & c.Row).Value = 0
Range("K" & c.Row).Value = 0
MsgBox "Moved ZERO to Initial Commisson and Month Paid"
End If
Next c
End If
haveError:
Application.EnableEvents = True
End Sub
NOTE: this is assumed to be in the relevant worksheet code module - otherwise you should qualify the Range() calls with a specific worksheet reference.
All your "change" handlers should follow a similar pattern.
Tim apologies. I am new to this and was anxious to get a solution. Thank you for your response. Advice Noted. T
When I attempt to insert or delete a row in the spreadsheet, the VBA code identifies a worksheet event and attempts to run the code. The spreadsheet crashes. I have attempted to add code that will prevent this by checking at the beginning of the module if a row has been inserted or deleted before the other worksheet change event if statements are checked
Thank you
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aCell As Range
Dim wsInc As Worksheet
Dim count As Integer
Dim lRow As Long
Dim ans As Variant
Dim tb As ListObject
On Error GoTo Whoa
Application.EnableEvents = False
Set tb = ActiveSheet.ListObjects(1)
MsgBox Target.Rows.count
If tb.Range.Cells.count > count Then
count = tb.Range.Cells.count
' GoTo Whoa
ElseIf tb.Range.Cells.count < count Then
count = tb.Range.Cells.count
' GoTo Whoa
'~~> Check if the change happened in Col A
ElseIf Not Intersect(Target, Columns(1)) Is Nothing Then
For Each aCell In Target.Cells
With aCell
If Len(Trim(.Value)) = 0 Then
.Offset(, 1).ClearContents
Else
.Offset(, 1).NumberFormat = "dd/mm/yyyy"
.Offset(, 1).Value = Now
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End With
Next
'~~> Check if the change happened in Col L
ElseIf Not Intersect(Target, Columns(12)) Is Nothing Then
Set wsInc = Sheets("Income")
lRow = wsInc.Range("A" & wsInc.Rows.count).End(xlUp).Row + 1
For Each aCell In Target.Cells
With aCell
If Len(Trim(.Value)) = 0 Then
.Offset(, 1).ClearContents
Else
.Offset(, 1).NumberFormat = "dd/mm/yyyy"
.Offset(, 1).Value = Now
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'~~> Check of the value is Fees Received, Policy No. Issued
If .Value = "Fees Received" Or .Value = "Policy No. Issued" Then
ans = MsgBox("Do you want to copy this client to the Income Worksheet?", vbQuestion + vbYesNo)
If ans = False Then Exit For
wsInc.Range("A" & lRow).Value = Range("A" & aCell.Row).Value
End If
End If
End With
Next
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
so I have an excel table with 2 columns: Times and Count, and 3 Rows: 1:00, 2:00 and 3:00 pm. I want functionality where when the user changes the count value for any of the rows, the count value minus 1 row should be added underneath. So for example for 1:00 pm below, when the user enters '4', it should add three rows below that row for a total of 4 rows. If the user changes the count to '2' it should remove 2 rows so that there are 2 total rows. This is what I have so far:
Times Count
1:00pm 4
2:00pm 0
3:00pm 0
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("C5:C100")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
'Save Workbook before so that original document will be saved
ActiveWorkbook.Save
Dim List As Long
Dim i As Long
Dim x As Long
Dim ExCnt As Variant
Dim aVal As Integer
'Find how many rows contain data
List = Range("B" & Rows.Count).End(xlUp).Row
For i = List To 2 Step -1
'Store exception value into variable
ExCnt = Range("C" & i).Value
With Range("C" & i)
'Insert rows unless text says Exception Count
If .Value > 1 And .Value <> "Exception Count" Then
.EntireRow.Copy
Application.EnableEvents = False
.Offset(1).EntireRow.Resize(.Value - 1).Insert
End If
CleanExit:
End With
Next i
Application.EnableEvents = True
End If
End Sub
This code adds the right amount of rows for each row but if the user changes the count value, the effect will compound for the existing rows.
I hope you appreciate how intricate this can actually be. :-)
Try this solution ...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim strKey As String, lngCount As Long, lngOffset As Long
Dim i As Long, rngNewRows As Range, lngTopRow As Long, lngBottomRow As Long
Dim bInBetween As Boolean
' Anymore than 10 cells and we'll skip this process.
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column = 2 Then
On Error Resume Next
Err.Clear
lngCount = Target.Value
On Error GoTo 0
If Err.Description = "" Then
If lngCount = 0 Then lngCount = 1
If lngCount > 0 Then
' Get the time value.
strKey = Target.Offset(0, -1).Text
bInBetween = False
' Check to make sure that the user isn't entering a value in between an already exploded set of rows.
If Target.Row > 1 Then
If Target.Offset(-1, -1).Text = strKey Then bInBetween = True
End If
If Not bInBetween Then
lngOffset = 0
' Now check each column below and delete or add rows depending on the count.
Do While True
lngOffset = lngOffset + 1
If Target.Offset(lngOffset, -1).Text <> strKey Then Exit Do
Loop
Application.EnableEvents = False
If lngOffset < lngCount Then
' We need to add rows.
Set rngNewRows = Target.Worksheet.Rows(Target.Offset(lngOffset, 0).Row & ":" & Target.Offset(lngOffset, 0).Offset(lngCount - lngOffset - 1, 0).Row)
lngTopRow = rngNewRows.Cells(1, 1).Row
lngBottomRow = rngNewRows.Cells(rngNewRows.Rows.Count, 1).Row
rngNewRows.Insert
For i = lngTopRow To lngBottomRow
Target.Worksheet.Cells(i, Target.Column - 1) = Target.Offset(0, -1).Value
Next
Else
If lngOffset <> lngCount Then
' We're over the count, determine the rows to delete.
Target.Worksheet.Rows(Target.Offset(lngCount, 0).Row & ":" & Target.Offset(lngOffset - 1, 0).Row).Delete
Else
' We have 1 row and that's all that's been asked for.
End If
End If
Application.EnableEvents = True
End If
End If
End If
End If
End Sub
... you clearly have some other rules that need to be applied but this should get you going. Check out the image below to see it in action.
A few points ...
It tries to cater for individuals entering values in column B within the exploded range and if they do that, it won't react to the value. Not sure if that's a requirement but I assumed it was.
0 will be treated as 1, so both 1, 0 and cleared will result in the resetting of the line.
Deletions happen at the bottom. So if the number goes from 10 to 3, it will delete the last set of rows to bring it back to 3.
It will only react to 1 cell at a time being changed. It reduced the complexity of the solution.
Outside of that, you're on your own. :-)
I have a workbook that creates daily reports in separate worksheets and at the end of the month I click a button that creates a monthly summary sheet from all of the individual daily sheets. The code that creates the monthly summary sheet has some lines that insert a blank row every 10 rows because the next day's data starts every 10 rows.
What I'm trying to do now is find the code that will insert the date into column A of the newly created blank rows. So column A in the first newly created blank line would contain 1/1/2018,The 2nd newly created blank row would have 1/2/2018 and so on.
Here is my current code, please let me know if you have any ideas for what to add to it to insert the dates in the newly created blank row. Another possible solution that I don't know how to implement would be copying the title of each worksheet to every 10th row since every worksheet is simply titled the date.
Sub endofmonth()
'This sub should be run at the end of the month and will generate a monthly summary sheet
Dim wrk As Workbook
Dim sht As Worksheet
Dim trg As Worksheet
Dim rng As Range
Dim colCount As Integer
Set wrk = ActiveWorkbook
For Each sht In wrk.Worksheets
If sht.Name = "Month End" Then
MsgBox "There is a worksheet called as 'Month End'." & vbCrLf & _
"Please remove or rename this worksheet since 'Month End' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
Application.ScreenUpdating = False
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
trg.Name = "Month End"
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
.Font.Bold = True
End With
For Each sht In wrk.Worksheets
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
trg.Columns.AutoFit
'This part of the code formats the Monthly Summary sheet correctly
With ThisWorkbook.Sheets("Month End")
.Columns(1).Resize(.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "HH:MM AM/PM"
.Columns(4).Resize(.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "00"
.Columns(10).Resize(.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "00.00"
.Columns(17).Resize(.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "0.00%"
.Columns(18).Resize(.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "0.00%"
.Columns(19).Resize(.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "0.00%"
'This part of the code inserts a break at the end of every day on the monthly summary sheet
Dim rw As Long
Dim lr As Long
Dim cnt As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
rw = 2
cnt = 1
Do
If cnt = 10 Then
Rows(rw).Insert Shift:=xlDown
cnt = 1
lr = Range("A" & Rows.Count).End(xlUp).Row
Else
cnt = cnt + 1
End If
rw = rw + 1
Loop While rw <> lr
End With
Application.ScreenUpdating = True
End Sub
Any help would be greatly appreciated!
Based on comment:
It would always be pressed on the last day of the month. So I would
have pressed it on the 30th of march since that's the last work day of
march.
You just need to add a variable keeping track of the day, and then use that variable inside the If cnt = 10 Then block.
Add this variable:
Dim DayIndex as Date: DayIndex = CDate(Evaluate("DATE(YEAR(TODAY()),MONTH(TODAY()),1)"))
And then:
If cnt = 10 Then
Rows(rw).Insert Shift:=xlDown
Cells(rw, "A").Value = DayIndex
Cells(rw, "A").NumberFormat = "d/m/yyyy"
DayIndex = DayIndex + 1
cnt = 1
lr = Range("A" & Rows.Count).End(xlUp).Row
Else
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
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