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
Related
I have a range A1:B10, for data entry, where A1:A10 for Item Name and B1:B10 for there Quantity.
I need the VBA for, If I entered same Item Name in Range A1:A10, they automatically SUM there Quantity in Range B1:B10, and delete the duplicate value entered?
For Example: -
A1 = Apple, B1 = 10
A2 = Coconut, B2 = 5
A3 = Banana, B3 = 8
And When I will enter
A4 = Apple, B4 = 2
Then
B1 Should be 12
and A4:B4 should be clear.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'On change of item, if Row found and add to receipt
If Not Intersect(Target, Range("E10")) Is Nothing And Range("E10").Value <> Empty Then AddItem
'On Change of Price Or Qty For Added Items
If Not Intersect(Target, Range("F8,F6")) Is Nothing And Range("B4").Value = False And Range("B6").Value <> Empty Then
Dim RecptRow As Long
RecptRow = Range("B6").Value 'Receipt Row
If Not Intersect(Target, Range("F6")) Is Nothing Then Range("M" & RecptRow).Value = Target.Value 'Update Price
If Not Intersect(Target, Range("F8")) Is Nothing Then Range("L" & RecptRow).Value = Target.Value 'Update Qty
End If
End Sub
Something like this should work.
Private Sub Worksheet_Change(ByVal Target As Range)
lastRow = Range("A" & Rows.Count).End(xlUp).Row ' or whatever other method used to determine lastrow
For Each xTarget In Target
If xTarget.Row = lastRow And xTarget.Column = 2 Then 'if B4 was changed
Call addIt(item:=Cells(xTarget.Row, xTarget.Column - 1), xTarget:=xTarget) ' passing in just xTarget so can use the value and the row
End If
Next xTarget
End Sub
Sub addIt(item, xTarget)
For x = 1 To xTarget.Row - 1 ' minus one because obviously dont wanna check the value you just now entered
If LCase(Trim(Cells(x, "A"))) = LCase(Trim(item)) Then ' lcase and trim to allow for whitespaces and case insensitivity
Cells(x, "B") = Cells(x, "B") + xTarget.value
'now will blank out if added to upper item
Application.EnableEvents = False
Cells(xTarget.Row, xTarget.Column) = "" 'b lr
Cells(xTarget.Row, xTarget.Column - 1) = "" 'a lr
Cells(xTarget.Row, xTarget.Column - 1).Activate 'a lr.activate
Application.EnableEvents = True
Exit Sub 'stop looping and get out
End If
Next x
End Sub
I use a for each xTarget in Target just in case you ever modify more than cell at a time(deleting something) so it wont throw an error
If lastrow column b was changed then it fires off the addIt sub
then it disables events so we don't get into an infinite loop if we then set lastrow column b and a to blank.
If you have more questions about this answer please add a comment! And mark as answered if this answers your question
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 need to change values of a column in EXCEL 2010 on Win 7.
This the macro. But, it only works for one cell even though I selected a column with 1000 tows.
Sub Change0to1()
SelectedRange = Selection.Rows.Count
ActiveCell.Select
For i = 1 To SelectedRange
If ActiveCell.Value = 0 Then
ActiveCell.Value = 1
End If
Next i
End Sub
Any help would be apprecaited.
Thanks
I think you want
Sub Change0to1()
For i = 1 To Selection.Cells.Count
If Selection(i).Value = 0 Then
Selection(i).Value = 1
End If
Next i
End Sub
This iterates through all the cells in the selection so it doesn't matter whether they are in a row and it doesn't matter which of the selected cells is the active cell.
Try this one:
Sub Change0to1()
Dim c As Range
For Each c In Selection
If c.Value = 0 Then c.Value = 1
Next c
End Sub
Note, that For Each loop is faster than For i = ..
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.
OK so here I go with my first question, advance apologies for any ambiguities.
I am working on a sheet where I pull data through SQL, and copy it to a certain table. The data contains string value. I am currently using vba to pull data (as there are variable involved), and copy it to grid how I want it.
The problem comes here; after I have copied the data, I have to merge certain Cells (sometimes two sometimes 3), and I do this manually. The condition is if C13 = C14 then merge, and if I merge C13 and C14 I have to merge B13 and B14 as well, and D13 and D14 as well. Next I want to check if the merged cell (which is now C13) is equal to C15, and then merge C13 to C15, and if this condition is true then B & D are also going to be merged.
If the condition of C13 is not true i.e. C13 <> C14 I want to go to next cell C14 and check if C14 = C15 or not.
I want to do this with vba, but trying to do this manually, will run into miles and miles of codes can someone please help?
This is the start of the code I have found here and managed to change a bit but now I am lost
Sub Merge()
Dim k As Range, cell As Range, name As String
Set k = Range("C13:C50")
For Each cell In k
If cell.Value =
End If
Next
End Sub
I could propose you the following code:
Sub Merge()
Dim k As Range, cell As Range, name As String
Set k = Range("C13:C50")
Application.DisplayAlerts = False
Do_it_again:
For Each cell In k
If cell.Value = cell.Offset(1, 0).Value _
And IsEmpty(cell) = False Then
Debug.Print cell.Address
'for column C
Range(cell, cell.Offset(1, 0)).Merge
'for column B
cell.Offset(0, -1).Resize(cell.MergeArea.Rows.Count, 1).Merge
'for column D
cell.Offset(0, 1).Resize(cell.MergeArea.Rows.Count, 1).Merge
GoTo Do_it_again
End If
Next
Application.DisplayAlerts = True
End Sub
I don't necessary like the code I proposed but after all it works as presented below.
Edit to improve efficiency
I have to admit that previous code wasn't efficient for big data table, like 5000 rows or more. One below is 90% faster but still need approx 10-20 sec for 5000 rows of data.
Most important changes compared to the code above are marked *****.
Sub Merge()
Dim k As Range, cell As Range, name As String
Dim kStart As Range, kEnd As Range '*****
Set kStart = Range("C13") '*****
Set kEnd = Range("C8000") '*****
Application.DisplayAlerts = False
Application.ScreenUpdating = False '*****
Do_it_again:
For Each cell In Range(kStart, kEnd) '*****
If cell.Value = cell.Offset(1, 0).Value _
And IsEmpty(cell) = False Then
Application.StatusBar = cell.Address '***** check progress in Excel status bar
'for column C
Range(cell, cell.Offset(1, 0)).Merge
'for column B
cell.Offset(0, -1).Resize(cell.MergeArea.Rows.Count, 1).Merge
'for column D
cell.Offset(0, 1).Resize(cell.MergeArea.Rows.Count, 1).Merge
Set kStart = cell '*****
GoTo Do_it_again
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True '*****
End Sub
Sorry, forgot to initialize count # 14
current = cells(13,3)
count = 14
for i = 14 to 15
next = cells(i,3)
If current = next then
'match encountered, merge columns B,C,D
for j = 2 to 4
cells(13,j) = cells(13,j) & cells(count,j)
next j
count = count + 1
end if
next i
If you are not trying to append but replace the value of C13 with C14 if matched, and C13 with C15 if matched etc..., then change the line
cells(13,j) = cells(13,j) & cells(count,j)
to
cells(13,j) = cells(count,j)