I'm trying to generate a code that will fill cells in a row based on the input of the selected cell. In a nutshell, there's 6 steps and the goal is to type "Step 6" in one cell and have Steps 5-1 generate in the 5 cells to the right, however the code cannot be restricted to a fixed cell and must move relative to the first cell selected. Is this possible? Ive used the week autofill as reference below but am lost.
Sub Weekday_Data_Update()
Dim startRange As Range
Dim stopRange As Range
Set startRange = Sheets("Sheet1").Range("A2")
'Specify the cell until which you want weekdays to be displayed
Set stopRange = Sheets("Sheet1").Range("A2:A6") startRange.Select
Selection.AutoFill Destination:=stopRange, Type:=xlFillWeekdays
End Sub
Like this (code goes in the worksheet module)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim v, i As Long
If Target.CountLarge > 1 Then Exit Sub 'only tracking single-cell changes
v = Target.Value
If IsError(v) Then Exit Sub 'cell has error - exit
If v = "Step 6" Then
For i = 5 To 1 Step -1
Target.Offset(0, 6 - i).Value = "Step " & i
Next i
End If
End Sub
Related
I am a beginner in VBA.
I have a Column "AA" can have multiple values, driven by formula of which 2 are "Impact Assessed" or "Ready for retesting".
Problem Statement - I want to record the dates when cell's value is changed to Impact Assessed and Ready for Retesting in 2 separate columns - Column B and Column C, respectively. I also want the ability of the macro to run if I copy-paste more than 1 cells triggering the change in my Column AA.
Below is my code -
Private Sub Worksheet_Calculate()
Dim rng As Range
If Target.CountLarge > 1 Then Exit Sub
Set rng = Application.Intersect(Me.Range("AA:AA"), Target)
If Not rng Is Nothing Then
Select Case (rng.Value)
Case "2 - Impact Assessed": rng.Offset(0, 1).Value = Date
Case "4 - Ready for retesting": rng.Offset(0, 2).Value = Date
End Select
End If
End Sub
Something like this:
Private Sub Worksheet_Calculate()
Dim rng As Range, c As Range, v
'get all cells with formulas
On Error Resume Next
Set rng = Me.Range("A:A").SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
'got some cells - loop over each cell
If Not rng Is Nothing Then
For Each c In rng.Cells
'make sure there's no error
If Not IsError(c.Value) Then
Select Case c.Value
Case "2 - Impact Assessed"
AddDateIfEmpty c.Offset(0, 1)
Case "4 - Ready for retesting"
AddDateIfEmpty c.Offset(0, 2)
End Select
End If
Next c
End If
End Sub
'utility sub: add date only if not already present
Sub AddDateIfEmpty(c As Range)
If Len(c.Value) = 0 Then c.Value = Date
End Sub
I have a large workbook and am trying to increase performance.
Is it possible/viable to store my formulas in some sort of list contained within the code rather than in the cells on the spreadsheet?
Variable SelectedRow = the currently selected row
For example:
ColumnBFormula = A(SelectedRow) + 1
ColumnCFormula = A(SelectedRow) + 2
If the user enters 4 in cell A3, then the macro writes formulas above ONLY in empty cells B3 and C3, then converts to values. The rest of the spreadsheet remains unchanged (should only have values everywhere).
Then the user enters a 6 in cell A4 and the spreadsheet writes the formulas to empty cells B4 and C4, calculates then converts to values.
Thanks
Try:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Lastrow As Long
'Refer to Sheet1
With ThisWorkbook.Worksheets("Sheet1")
'Check if Column A affected
If Not Intersect(Target, Range("A:A")) Is Nothing And IsNumeric(Target) Then
'Disable event to avoid event trigger
Application.EnableEvents = False
Target.Offset(0, 1).Value = Target + 1
Target.Offset(0, 2).Value = Target + 2
'Enable event
Application.EnableEvents = True
End If
End With
End Sub
Instructions:
Enable Events:
Given you know what you want the code to do, you could do this without entering formulas.
In the VBA editor, add this code into the "ThisWorkbook" object ...
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim objCell As Range
Application.EnableEvents = False
For Each objCell In Target.Cells
If objCell.Column = 1 Then
If objCell.Value = "" Then
objCell.Offset(0, 1) = ""
objCell.Offset(0, 2) = ""
Else
objCell.Offset(0, 1) = objCell.Value + 1
objCell.Offset(0, 2) = objCell.Value + 2
End If
End If
Next
Application.EnableEvents = True
End Sub
Hopefully that works for you.
FYI - You'll need to add the relevant error checking for values if not numeric etc, it will need to be improved.
I'm having a problem of iterating through a range of items in a for loop:
How the procedure is supposed to work-
I start off on worksheet 1("Tracking Spreadsheet"), and depending on a change in worksheet 1 ( selecting "yes" in a cell) it would transfer you to worksheet 2("Deferred Submittals") and then iterate through a range of cells ( A1:A20 for example) from worksheet 2. The for loop would keep going until it reached a cell that was empty, and stop and then proceed to write into that cell.
How its working now-
I start off on worksheet 1, and depending on a change in worksheet 1 ( selecting "yes" in a cell) it would transfer you to worksheet 2 and then iterate through a range of cells ( A1:A20 for example) from worksheet 2. However, instead of iterating through worksheet 2's A1:A20, it would iterate through worksheet 1's A1:A20. After it found an empty cell in worksheet 1's A1:A20 range, it would then fill in the corresponding cell in Worksheet 2 ( If A5 is empty on worksheet 1, it would then fill in A5 on worksheet 2).
I was hoping to get help on having the range iterate through the active sheet at the time ( worksheet 2) instead of iterating through worksheet 1.
My code so far:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
' Deferred Submittal, Column C = 3
Dim cellTextDS As String
Dim deferredArray As Range, deferredCell As Range, deferredRowEmpty As Long
deferredRowEmpty = 1
' Deferred Submittal, Column C
If Target.Column = 3 Then
Row = Target.Row
cellTextDS = ActiveSheet.Range("C" & Row).Text
If cellTextDS = "Yes" Then
Sheets(3).Activate
Set deferredRange = Workbooks("BPS Tracking Sheet v6.xlsm").Worksheets("Deferred Submittals").Range("A1:A20")
For Each deferredCell In deferredRange
Sheets(3).Activate
MsgBox "inside deferredCell is " & deferredCell
MsgBox " active sheet currently is " & name
If IsEmpty(Range("A" & deferredRowEmpty).Value) = True Then Exit For
MsgBox " deferredRowEmpty is " & deferredRowEmpty
deferredRowEmpty = deferredRowEmpty + 1
Next deferredCell
MsgBox "Moving to 'Deferred Submittals' tab in order to input more information. row is " & deferredRowEmpty
ActiveSheet.Range("A" & deferredRowEmpty).Value = "empty"
End If
End If
End Sub
Any help would be really appreciated!
p.s. the code is in the worksheet_change section of worksheet 1 if that makes any difference.
p.s.s. I've tried using this stackoverflow method for setting workbooks and worksheets, to no avail
p.s.s.s. posted the rest of my code for this portion. There is more code in this section, but it is literally just copy and paste of this section but for different columns. I've also edited what worksheet 1 and 2 are, but they are the different worksheet tabs in this workbook, specifically worksheet 1 = "Tracking Spreadsheet" and worksheet 2 = "Deferred Submittals"
OK - I think this is the kind of thing you're looking for. When using the worksheet_change event there are a few things that should be done.
Disabling events means the macro can run without triggering further erroneous change calls and therefore having some error management is required.
I have left a commented line which may be of use so that any changes on multiple cells at one time won't trigger further changes and will just exit the sub
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'If Target.Cells.Count > 1 Then Exit Sub
If Target.Column <> 3 Then Exit Sub
On Error GoTo ExitSub
Application.EnableEvents = False
Dim wsSource As Worksheet: Set wsSource = Me
Dim wsTarget As Worksheet: Set wsTarget = ThisWorkbook.Worksheets("Deferred Submittals")
Dim NextEmpty As Range
If wsSource.Cells(Target.Row, 3) = "Yes" Then
Set NextEmpty = wsTarget.Range("A1:A20").Find("", LookIn:=xlValues)
If Not NextEmpty Is Nothing Then
Debug.Print NextEmpty.Address ' Function check
NextEmpty.Value = Target.Row ' Or whatever you want the value to be
End If
End If
ExitSub:
Application.EnableEvents = True
End Sub
I have some people, whose working time are shown by the conditional formatting in the cells on their own columns - e.g. B7:B36, C7:C36, D7:D36 and so. I try to count the conditional formatting cells to the column E. The end result in the cell is #Value (Arvo), but when you press F9, then the numbers can be displayed.
When I run the code step by step, I noticed that after the line "Range("B6", ws.Cells.SpecialCells(xlCellTypeLastCell)).ClearFormats program jump to function "Function CountRed(MyRange As Range" and stay in the Loop for some time.
Is this because that there is a function "CountRed(B6)+CountGreen(C6)+CountBlue(D6)" for example in the cell E6?
In addition, I would like the column numbers in column E are concentrated in the central.
Error if exit time is empty:
Result with error in col E:
Results should look like this:
The original code can be also found here - Thanks Floris!
Option Explicit
Private Sub worksheet_change(ByVal target As Range)
If Not Intersect(target, Range("B4:Q4")) Is Nothing Then
'Sub makeTimeGraph()
Dim startRow As Long
Dim endRow As Long
Dim entryTimeRow As Long
Dim entryTimeFirstCol As Long
Dim Applicaton
Dim ws As Excel.Worksheet
Dim timeRange As Range
Dim c
Dim timeCols As Range
Dim entryTime
Dim exitTime
Dim formatRange As Excel.Range
Dim eps
eps = 0.000001 ' a very small number - to take care of rounding errors in lookup
Dim entryName
Dim Jim
Dim Mark
Dim Lisa
Dim nameCols As Range
' change these lines to match the layout of the spreadsheet
' first cell of time entries is B4 in this case:
entryTimeRow = 4
entryTimeFirstCol = 2
' time slots are in column A, starting in cell A6:
Set timeRange = Range("A6", [A6].End(xlDown))
' columns in which times were entered:
Set ws = ActiveSheet
Set timeCols = Range("B4:Q4") ' select all the columns you want here, but only one row
Set nameCols = Range("B3:Q3") ' columns where the names are in the third row
' clear previous formatting
Range("B6", ws.Cells.SpecialCells(xlCellTypeLastCell)).ClearFormats
Application.ScreenUpdating = False
' loop over each of the columns:
For Each c In timeCols.Cells
Application.StatusBar = entryName
If IsEmpty(c) Then GoTo nextColumn
entryTime = c.Value
exitTime = c.Offset(1, 0).Value
entryName = c.Offset(-1, 0).Value
startRow = Application.WorksheetFunction.Match(entryTime + eps, timeRange) + timeRange.Cells(1.1).Row - 1
endRow = Application.WorksheetFunction.Match(exitTime - eps, timeRange) + timeRange.Cells(1.1).Row - 1
Set formatRange = Range(ws.Cells(startRow, c.Column), ws.Cells(endRow, c.Column))
'select format range
formatRange.Select
' select name for coloring
Select Case entryName
Case "Jim"
Call formatTheRange1(formatRange) ' Red Colorinex 3
Case "Mark"
Call formatTheRange2(formatRange) ' Green Colorindex 4
Case "Lisa"
Call formatTheRange3(formatRange) ' Blue Colorindex 5
End Select
nextColumn:
Next c
End If
Range("A1").Activate
Application.ScreenUpdating = True
End Sub
Private Sub formatTheRange1(ByRef r As Excel.Range)
r.HorizontalAlignment = xlCenter
r.Merge
' Apply color red coloroindex 3
With r.Interior
.Pattern = xlSolid
.ColorIndex = 3
'.TintAndShade = 0.8
Selection.UnMerge
End With
End Sub
Private Sub formatTheRange2(ByRef r As Excel.Range)
r.HorizontalAlignment = xlCenter
r.Merge
' Apply color Green Colorindex 4
With r.Interior
.Pattern = xlSolid
.ColorIndex = 4
'.TintAndShade = 0.8
Selection.UnMerge
End With
End Sub
Private Sub formatTheRange3(ByRef r As Excel.Range)
r.HorizontalAlignment = xlCenter
r.Merge
' Apply color Blue Colorindex 5
With r.Interior
.Pattern = xlSolid
.ColorIndex = 5
'.TintAndShade = 0.8
Selection.UnMerge
End With
End Sub
Function CountRed(MyRange As Range)
Dim i As Integer
Application.Volatile
i = 0
For Each cell In MyRange
If cell.Interior.ColorIndex = 3 Then
i = i + 1
End If
Next cell
CountRed = i
End Function
Function CountGreen(MyRange As Range)
Dim i As Integer
Application.Volatile
i = 0
For Each cell In MyRange
If cell.Interior.ColorIndex = 4 Then
i = iCount + 1
End If
Next cell
CountGreen = i
End Function
Function CountBlue(MyRange As Range)
Dim i As Integer
Application.Volatile
i = 0
For Each cell In MyRange
If cell.Interior.ColorIndex = 5 Then
i = i + 1
End If
Next cell
CountBlue = i
End Function
The #VALUE!(ARVO) error could be overcome by adding ws.Calculate to the end of your Private Sub worksheet_change(ByVal target As Range) procedure.
That said, your desired outcomes:
Graphic representation of time being worked by employees
How many people are working during different time intervals
Can be accomplished using conditional formatting in columns B:D and COUNTIFS functions in column E.
To set up the conditional format in column B:
Select from B6 down to the cell adjacent to the last time in column A
Click Conditional Formatting and click on the "Use a formula..." option
Enter =AND(A6>=B$4,$A6<B$5) in the formula box
Click the Format.. button and select Fill colour
Click OK
Click Apply or OK to see the result or close the dialogue
You can copy the conditional formats to columns C and D then edit their fill colours as desired.
In cell E6 inter the formula:
=COUNTIFS(A6,">="&B$4,A6,"<"&B$5)
+COUNTIFS(A6,">="&C$4,A6,"<"&C$5)
+COUNTIFS(A6,">="&D$4,A6,"<"&D$5)
Copy from B6 down to E last time row into F6; J6 etc.
By not using VBA at all you will improve worksheet performance. It's usually better to use Excel functionality and built-in functions where possible and reserve VBA to do repetitive tasks and create UDFs to calculate thing that can't be done using built-in functions.
Hyvää päivää! It's me again… Good to see you are continuing to improve your code. I have made a few tweaks to make it work a bit better. In particular:
Modified the test of the Target - so it will update both when you change the start time, and when you change the end time. You were only doing things when the start time was changed.
Just one formatting function instead of 3, with a second parameter (color). This keeps the code a little tidier. You could even have a dictionary of key/value pairs - but that doesn't work on a Mac which is where I'm writing this so I won't show you.
Hidden inside the colored cell is the number 1, with the same color as the background (hence "invisible") - this is added by the formatting function
Now your "sum" column can just contain a SUM(B6:D6) style formula that you copy down the column. This is considerably faster than three custom functions that check for the color in the cells to their left… (removed those functions from the code)
Have to clear the entire column's values (not just formatting) to remove any 1s left over from a previous run; this is done in the per-column loop (rather than all at once) to preserve the SUM() formulas in the "per day" columns.
Nothing is ever selected by the code - so there's nothing to unselect at the end; this means that the selection doesn't jump to the A1 cell every time you make an edit.
Removed the Dim Jim etc statements since you did not use those variables.
Now that the code is modifying the sheet (changing the values in cells by adding the invisible ones) there is a risk of things really slowing down (every change causes the event to fire again) - so I am turning off the events when you enter the function, and turn them on again when you leave (using Application.EnableEvents = False or True respectively); to be safe, errors are also trapped (with On Error GoTo whoops) - these send your code straight to the "enable events and exit function" part of the code.
Presumably you have figured out that this code needs to live in the worksheet code (rather than a regular module) in order to receive the events properly.
Here is the new code:
Option Explicit
Private Sub worksheet_change(ByVal target As Range)
On Error GoTo whoops
If Not Intersect(target, Range("B4:Q5")) Is Nothing Then
Dim startRow As Long
Dim endRow As Long
Dim entryTimeRow As Long
Dim entryTimeFirstCol As Long
Dim Applicaton
Dim ws As Excel.Worksheet
Dim timeRange As Range
Dim c
Dim timeCols As Range
Dim entryTime
Dim exitTime
Dim formatRange As Excel.Range
Dim eps
eps = 1e-06 ' a very small number - to take care of rounding errors in lookup
Dim entryName
Dim nameCols As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
' change these lines to match the layout of the spreadsheet
' first cell of time entries is B4 in this case:
entryTimeRow = 4
entryTimeFirstCol = 2
' time slots are in column A, starting in cell A6:
Set timeRange = Range("A6", [A6].End(xlDown))
' columns in which times were entered:
Set ws = ActiveSheet
Set timeCols = Range("B4:Q4") ' select all the columns you want here, but only one row
Set nameCols = Range("B3:Q3") ' columns where the names are in the third row
' clear previous values and formatting
Range("B6", ws.Cells.SpecialCells(xlCellTypeLastCell)).clearFormats
' loop over each of the columns:
For Each c In timeCols.Cells
'Application.StatusBar = entryName
If IsEmpty(c) Then GoTo nextColumn
entryTime = c.Value
exitTime = c.Offset(1, 0).Value
entryName = c.Offset(-1, 0).Value
startRow = Application.WorksheetFunction.Match(entryTime + eps, timeRange) + timeRange.Cells(1.1).Row - 1
endRow = Application.WorksheetFunction.Match(exitTime - eps, timeRange) + timeRange.Cells(1.1).Row - 1
' get rid of any values currently in this row:
timeRange.Offset(0, c.Column - 1).Clear
Set formatRange = Range(ws.Cells(startRow, c.Column), ws.Cells(endRow, c.Column))
' select name for coloring
Select Case entryName
Case "Jim"
Call formatTheRange(formatRange, 3) ' Red Colorindex 3
Case "Mark"
Call formatTheRange(formatRange, 4) ' Green Colorindex 4
Case "Lisa"
Call formatTheRange(formatRange, 5) ' Blue Colorindex 5
End Select
nextColumn:
Next c
End If
whoops:
If Err.Number > 0 Then
MsgBox "error: " & Err.Description
Err.Clear
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Private Sub formatTheRange(ByRef r As Excel.Range, c)
Dim cc
' Apply color c
With r.Interior
.Pattern = xlSolid
.ColorIndex = c
End With
r.Font.ColorIndex = c
' put an invisible 1 in each cell:
For Each cc In r.Cells
cc.Value = 1
Next
End Sub
Here's how things look (just one set of columns showing - but this should work fine in your multi-column version):
I am not a fan of writing macro, unless you exhausted the capabilities of Excel. Instead of attacking the problem through the ColorIndex, go back to the source of your data. Use this formula on E6
{=SUM(($B$4:$D$4<=A6)*($B$5:$D$5>A6))}
Remember to use Ctrl+Shift+Enter to enable the array function, instead of just Enter. Paste down and it will perform the behavior you are aiming for.
If the following conditions are met:
For any given row between row 10 and row 100 inclusively:
The cell in column A is not empty
The cell in column B is not empty
The cell in column O is empty
I would like to highlight a specific cell (let's say A1).
Example:
I populate A10 and E10 while leaving O10 empty, then cell A1 gets highlighted. If I then populate cell O10, the highlight in cell A1 disappears.
I can proceed to the next row. Any row at any time should generate these actions.
Thanks!
This will do the highlights based on the conditions you specified. When you run it, it'll stop at the first row you need to input something in column O. If you want it to keep running until row 101 and highlight all the rows, then remove then Exit Do command that's between the 2 End If statements.
Sub Highlight()
Dim TheRow As Integer
TheRow = 9
Application.ScreenUpdating = False 'This hides the visual process and speeds up
'the execution
Do
TheRow = TheRow + 1
If TheRow = 101 Then Exit Do
Cells(TheRow, 1).Select
Selection.Interior.Pattern = 0
Cells(TheRow, 2).Select
Selection.Interior.Pattern = 0
If Not Cells(TheRow, 1).Value = "" And Not Cells(TheRow, 2).Value = "" And Cells(TheRow, 15).Value = "" Then
If Cells(TheRow, 1).Value = "" Then
Cells(TheRow, 1).Select
Selection.Interior.Color = 656
End If
If Cells(TheRow, 2).Value = "" Then
Cells(TheRow, 2).Select
Selection.Interior.Color = 656
End If
Exit Do 'this is the line to remove if you want to highlight all cells
End If
Loop
Application.ScreenUpdating = True
End Sub
And then, create an event handler that triggers when a cell in column 15 changes. Put the following code in the module of the actual worksheet (in the VBA project explorer, double click on the sheet you want have this functionality for; don't put this in a different module!)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 15 Then
If Target.Row > 9 And Target.Row < 101 Then Call Highlight
End Sub
Let me know if this solution works and remember to click "accept solution" and to vote for it!
Happy coding.
You don't need VBA: just use conditional formatting on cell A10 with the following formula:
=AND(NOT(ISBLANK($A10)),NOT(ISBLANK($B10)),ISBLANK($O10))
OK - I misunderstood what you wanted. Here is a VBA UDF to do the checking.
Enter =Checker($A$10:$B$100,$O$10:$O$100) in cell A1, then use conditional formatting on cell A1 that is triggered when it becomes True.
Public Function Checker(theRangeAB As Range, theRangeO As Variant) As Boolean
Dim varAB As Variant
Dim varO As Variant
Dim j As Long
varAB = theRangeAB.Value2
varO = theRangeO.Value2
Checker = False
For j = 1 To UBound(varAB)
If Not IsEmpty(varAB(j, 1)) And Not IsEmpty(varAB(j, 2)) Then
If IsEmpty(varO(j, 1)) Then
Checker = True
Exit For
End If
End If
Next j
End Function