I am new to VBA and require some assistance. I have found VBA that will look at the value of the active cell and insert a number of rows equal to the value in the cell.
The problem I have is that this only works for the active cell, I have a column for which I would like this process to be automated for. Would anyone know what I should change in the code below?
Sub InsertSome()
Dim i As Integer, n As Integer, m As Long
n = ActiveCell.Value
m = ActiveCell.Row
For i = 1 To n
Rows(m * i + 1).Insert
Next i
End Sub
Thanks in Advance!
You have to use Events. Insert this code in the module of the sheet where you want this working. It will run every time you select a cell in column C.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("C:C")) Is Nothing And Target.Value <> "" Then '<-Change "C:C" to your column
Dim i As Integer, n As Integer, m As Long
n = Target.Value
m = Target.Row
For i = 1 To n
Rows(m * i + 1).Insert
Next i
End If
End Sub
You can use one of the Worksheet events, such as Worksheet_SelectionChange or Worksheet_Change events.
Also, you don't need to have so many variables, you can use the properties of Target object (equivalent to ActiveCell). Also, you can add multiple rows at once (there's no need to have a For loop).
Code
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' modify column "A" to your desired column
If Not Intersect(Target, Range("A:A")) Is Nothing Then
' make sure the value is numeric, positive, and you select a single cell
If Target.Value > 0 And Trim(Target.Value) <> "" And IsNumeric(Target.Value) And Target.Cells.Count = 1 Then
' no need for a loop to add 1 row at a time,
' just use the line below to add the number of rows in the Target (acitveCell) at once
Range(Cells(Target.Row + 1, 1), Cells(Target.Row + Target.Value, 1)).EntireRow.Insert
End If
End If
End Sub
Related
I have a sheet and the user input Starts in A7 and calculations are inserted with a macro to B7 all the way through I.
I got all that worked out but what i need is: the user is going down typing in data in Column A, lets say they input data Starting from A7, through A11, then skip A12 and type into A13, i want the sheet to automatically move the user's input into A12 so there's never any blank rows IN BETWEEN the data in column A.
Ideally all the data should be in sequence and there shouldn't be any blank rows in between the data entered in column A.
Here is the code i have come up with thus far:
Private Sub worksheet_change(ByVal Target As Range)
Dim r As Integer
Dim c As Integer
1 If Not Intersect(Target, Range("A:C")) Is Nothing Then
If Target.Row >= Range("FormulaRange").Row + 1 Then
If Target.Row <= Range("RowTracker").Value + 1 Then
Dim t
RWS = Target.rows.Count
COLS = Target.Columns.Count
For r = 1 To RWS
For c = 1 To COLS
If Not IsNumeric(Target.rows.Cells(r, c).Value) Then
'Else
MsgBox "Please enter only numeric values."
Application.Undo
'End
Else
If Target.rows.Cells(r, 2) = "" Then Target.rows.Cells(r, 2) = 0
If Target.rows.Cells(r, 3) = "" Then Target.rows.Cells(r, 3) = 0
End If
Next c
Next r
Else
MsgBox "Please enter data in the next available line."
Exit Sub
End If
End If
End If
End Sub
Right now it detects if i skip rows and input arbitrarily in A giving me a warning not to do so but i would love it just took my input and put it back into the next available row in column A.
I thought about doing a Row.Delete but the way the code is set up is keeps detecting the deleted row as skipping cells in A column continuously giving me the error of "Please Enter Data in the next available line."
Key point missing is to prevent a cascade of events as you change the sheet. Use Application.EnableEvent = False to prevent this.
Then deleting rows with blanks will work, something like this
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rw As Long
Dim i As Long, j As Long
On Error GoTo EH
If Not Application.Intersect(Target, Me.Columns("A:C")) Is Nothing Then
rw = Me.Cells(Me.Rows.Count, 1).End(xlUp).Row
' Prevent a cascade of events
Application.EnableEvents = False
For i = rw To 1 Step -1
'Check for blanks in column A, delete row if found
If IsEmpty(Me.Cells(i, 1)) Then
Me.Rows(i).Delete
End If
'check for non numeric data
For j = 1 To 3
If Not IsNumeric(Me.Cells(i, j)) Then
Me.Cells(i, j).ClearContents
End If
'Enter Zeros's
If j > 1 Then
If IsEmpty(Me.Cells(i, j)) Then
Me.Cells(i, j) = 0
End If
End If
Next
Next
End If
EH:
' restore event handling
Application.EnableEvents = True
End Sub
Notes:
The delete rows and check for non numeric/blanks will interact, possibly in ways you don't expect
If user leaves column A blank and enters data into other columns, it will be deleted
I've left out the Named Range checks, as I'm unsure what they are doing. You can reinstate to suit.
Might be better to validate and warn the user before deleting
Something like this will force the user to only stay in the next possible row for column A without being able to enter more information.
This isn't foolproof, but will get you started. You can extend as needed:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 1 And Target.Row <> 1 Then
If Len(Target.Offset(-1)) = 0 Then
Target.Offset(-1).Select
End If
End If
End Sub
I am using the event handler, and I run certain events if either one cell or two cells are selected. The issue I'm having is, when two cells are selected, I don't know how to access the attributes of that 2nd cell (Ie, what it's value is). Any idea how I can access the value of the 2nd cell thats selected (I was hoping Target would be an array object, and I could just select by array index....)
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo disError
If Target.Cells.Count > 2 Or Target.Address = Range("DataHist").Address Then Exit Sub
Dim curve As String
Dim Ticker As String
Dim TickerTwo As String
Dim lastValue As Double
TickerTwo = ""
If Target.Cells.Count = 1 Then
Ticker = Target.Value
lastValue = Round(Target.Offset(0, 1).Value, 3)
curve = CheckLabel(Target)
Else
' This is where the issue is --------------------------------
Ticker = Target.Cells(1, 1).Value
TickerTwo = Target.Next.Value
lastValue = Round(Target.Offset(0, 1).Value, 3)
curve = CheckLabel(Target)
' -----------------------------------------------------------
End If
Select Case curve
Case "na"
Exit Sub
Case "Test1"
Call FillChart("Test1", Ticker, lastValue, TickerTwo)
Case "Test2"
Call FillChart("Test2", Ticker, lastValue, TickerTwo)
End Select
disError:
End Sub
If you don't know if the User is going to select cells in a column or cells in a row, or even a block of cells, use a loop and counter:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Range, i As Long
i = 1
If Target.Count > 1 Then
For Each r In Target
MsgBox r.Address(0, 0) & vbCrLf & i
i = i + 1
Next r
End If
End Sub
Then process when i=2. It will be the cell-to-the-right if a block or row is selected or the cell-below if part of a column is selected.
While this is not pretty code, at least it will work, even if the User selects a disjoint set of cells.
EDIT#1:
You can avoid the ugly loop if you are willing to parse Selection.Address
EDIT#2:
This code (without any loops) will work if the User selects 2 and only 2 cells:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim s As String
If Target.Count = 2 Then
s = Split(Replace(Target.Address(0, 0), ":", ","), ",")(1)
MsgBox "The second cell is: " & s
End If
End Sub
I need help with an macro to notify me (by changing a cell background color to red), when the value (always number format) changes in any cells in the row. I want the background of cell E3 to change to red, if any of the values in cells F3:AN3 change from their current values.
The numbers in cells F3:AN3 will be entered manually or thru copy and paste of the row, and there won't be any formulas. Likewise, if any values in cells F4:AN4 are changed, I would like cell E4 to change to a red background, and so on for each of the rows in the chart. Not all rows will always have a value, so I would be looking for changes from "" to any #, or from one # to another #, or from any # to "". Ideally this would be an event macro that does not have to be run manually.
The following is the code I've started working with:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("F3:AN3")) Is Nothing Then KeyCellsChanged
End Sub
Private Sub KeyCellsChanged()
Dim Cell As Object
For Each Cell In Range("E3")
Cell.Interior.ColorIndex = 3
Next Cell
End Sub
However, this macro seems to run regardless of whether the number in the cell is changed, as long as I press enter it highlight E3 as red.
Any help is much appreciated!
Here is my favorite way to detect changes in an Excel VBA app:
Create an exact copy of the range you're watching in hidden rows below the range the user sees.
Add another section below that (also hidden) with formulas subtracting the user range with the hidden range with an if statement that sets the value to 1 if the difference is anything but 0.
Use conditional formatting in the user range that changes the background color of the row if the corresponding change-detection row (or cell) is > 0.
What I like about this approach:
If a user makes a change and then reverts back to the original value, the row is "smart enough" to know that nothing has changed.
Code that runs any time a user changes something is a pain and can lead to problems. If you set up your change detection the way I'm describing, your code only fires when the sheet is initialized. The worksheet_change event is expensive, and also "may effectively turn off Excel’s Undo feature. Excel’s Undo stack is destroyed whenever an event procedure makes a change to the worksheet." (per John Walkenbach: Excel 2010 Power Programming)
You can detect if the user is navigating away from the page and warn them that their changes will be lost.
Depending on your answer to my question in the comments, this code may change. Paste this in the relevant Worksheet code area. For this to work, navigate to any other sheet and then navigate back to the original sheet.
Option Explicit
Dim PrevVal As Variant
Private Sub Worksheet_Activate()
If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
PrevVal = Selection.Value
Else
PrevVal = Selection
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo ExitGraceFully
If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
PrevVal = Selection.Value
Else
PrevVal = Selection
End If
ExitGraceFully:
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Application.WorksheetFunction.CountA(Target) = 0 Then Exit Sub
Dim aCell As Range, i As Long, j As Long
On Error GoTo Whoa
Application.EnableEvents = False
If Not Intersect(Target, Columns("F:AN")) Is Nothing Then
If Target.Rows.Count = 1 And Target.Columns.Count >= 1 Then
Range("E" & Target.Row).Interior.ColorIndex = 3
ElseIf Target.Rows.Count > 1 And Target.Columns.Count = 1 Then
i = 1
For Each aCell In Target
If aCell.Value <> PrevVal(i, 1) Then
Range("E" & aCell.Row).Interior.ColorIndex = 3
End If
i = i + 1
Next
ElseIf Target.Rows.Count > 1 And Target.Columns.Count > 1 Then
Dim pRow As Long
i = 1: j = 1
pRow = Target.Cells(1, 1).Row
For Each aCell In Target
If aCell.Row <> pRow Then
i = i + 1: pRow = aCell.Row
j = 1
End If
If aCell.Value <> PrevVal(i, j) Then
Range("E" & aCell.Row).Interior.ColorIndex = 3
End If
j = j + 1
Next
End If
End If
LetsContinue:
Application.EnableEvents = True
Exit Sub
Whoa:
Resume LetsContinue
End Sub
SNAPSHOTS
It works as expected When you type a value in the cell. It also works when you copy 1 Cell and paste it in multiple cells. It doesn't work when you copy a block of cells and do a paste (I am still working on this)
NOTE: This is not extensively tested.
Based on a language table, column A = Language, B = number, C = coloredcell
I would like to know what is the VBA so whenever I type a number on Column B (using Workbook_SheetChange), C is colored with the Colorindex equal to the number typed.
On the other hand, and I am sure is part of the solution to the previous question, on VBA how do I write cell.Interior.ColorIndex = (a specific cell value, If B2=4 -> for the row, whole or until last column has data, cell.Interior.ColorIndex = 4) and color the whole row.
Thank you
The sheetchange function has target as an argument, that's the cell that you changed. You can use it to change the relevant cell:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 Then
Target.Offset(0,1).Interior.ColorIndex = Target.Value
'and for the whole row
Target.EntireRow.Interior.Color = Target.Offset(0,1).Interior.Color
Endif
End Sub
The code of Nick Dewitt is OK, but it color only the column C.
If you want to color the entire row, starting from C depending of how much columns are in the row :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastcol As Integer, i As Integer
If Target.Column = 2 Then
lastcol = Cells(Target.Row, Columns.Count).End(xlToLeft).Column
For i = 3 To lastcol
Target.Offset(0, i - 2).Interior.ColorIndex = Target.Value
Next i
End If
End Sub
Right click on the sheet's name on which you want this functionality, and click on 'View Code'.
Now you need to write a VBA function that fires on any change to the worksheet. This is an inbuilt function called Worksheet_Change(Range). The range object (it's argument) is the range that had changed when this function fired.
Private Sub Worksheet_Change(ByVal Target As Range)
End Sub
Inside the function you need to check whether the changed cell was in column B. This is done by the Column property of the Target range.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 Then
' The changed cell was in column B
End If
End Sub
Now you need to get the cell's value and put it as the row's ColorIndex.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 Then
ColorValue = Target.Value
Target.EntireRow.Interior.ColorIndex = ColorValue
End If
End Sub
Edit: To color the cells only till the last value in the row, you need to count the number of filled cells in the row. The following code does that (see the comments to understand it)
Private Sub Worksheet_Change(ByVal Target As Range)
' Check if the edited cell is in column B
If Target.Column = 2 Then
' Get the value of the edited cell
ColorValue = Target.Value
' Get the row number of the edited cell
RowNumber = Target.Row
' Get the number of filled cells in this row
CellsCount = Application.WorksheetFunction.CountA(Range(RowNumber & ":" & RowNumber))
' Apply the color formatting till the last column in this row
Range(Cells(RowNumber, 1), Cells(RowNumber, CellsCount)).Interior.ColorIndex = ColorValue
End If
End Sub
I have a train arrival/departure timetable, each branch line is on a separate row. I need to make the spreadsheet automatically detect change in cell and change all cells to the right from it for the same amount of time. Cells have format of time. How do I do that?
What I've tried so far:
I found this piece of code in some other question on SE:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Target.Worksheet.Range("H5")) Is Nothing Then Macro
End Sub
But I wasn't able to understand where to put it and how to make it work automatically, apart from working for a specific range, which might be different from what was in the question where I found it.
UPD: The logic I'm looking for in VBA:
Wait until a cell is selected, if it has Time format, copy its value to Tmp.
Save the difference between old and new values to Tmp.
If a cell to the right contains something and its format is Time, add Tmp to it.
Continue until cell is empty.
if you know how much difference is between times, then you can calculate the new time based on that difference.
e.g. A1 is 10:07, A2 is 10:14. Instead of having to type in each time individually, you could have A2 as =A1+TIME(0,7,0). Then when you changed A1 to 10:15, A2 would automatically change to 10:22
OK this may get you started in the right direction:
You first want to store all the original cell values. So, the following VBA code stores the values in column A for the first 200 rows into an array. You need to run this code first, perhaps when the workbook is opened:
Dim contents(200) As Variant
Public Sub StoreOriginalValues()
' save all existing values
For r = 1 To 200 ' change for number of rows you have
contents(r) = Worksheets(1).Cells(r, 1).Value
Next
End Sub
Once the original cell values are stored, you can place code in the Worksheet_Change event so that whenever the user changes a cell in column A you can compare the original and new value and figure out the difference. Then you can apply this difference to the rest of the columns in that row:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then ' only check for changes in column A
originalvalue = contents(Target.Row)
newvalue = Target.Value
contents(Target.Row) = Target.Value
difference = newvalue - originalvalue
Set chgcell = Cells(Target.Row, Target.Column + 1)
Do While Not IsEmpty(chgcell)
chgcell.Value = chgcell.Value + difference
Set chgcell = chgcell.Offset(0, 1) ' move one column to right
Loop
End If
End Sub
Now this code is by no means perfect. It does not check that they entered a valid time, for instance. It also does not check to see if the values entered in the rest of the columns in the row are times or text or whatnot. But like I said I hope it will point you in the right direction.
My solution:
Dim oldVal
Dim diff
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
oldVal = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
ActiveCell.Offset(-1, 0).Select
Application.EnableEvents = True
diff = Target.Value - oldVal
If Not diff = 0 Then
While Not ActiveCell.Offset(0, 1) = "#"
Application.EnableEvents = False
ActiveCell.Offset(0, 1).Select
Application.EnableEvents = True
If Not ActiveCell Is Nothing _
And Not ActiveCell = "" _
And TypeName(ActiveCell) = TypeName(ActiveCell.Offset(0, -1)) Then
Application.EnableEvents = False
ActiveCell.Value = ActiveCell.Value + diff
Application.EnableEvents = True
End If
Wend
End If
End Sub
This has been my first experience with VB in a very long time, so the code is terrible, but it works.