here you see the lines for merging certain cells when a row is inserted.
Range(Cells(ActiveCell.row, "H"), Cells(ActiveCell.row, "L")).mergeCells = True
Range("H" & ActiveCell.row + 1).Resize(, 5).Merge
i would like to add a range value but i can't find how or where to add it in the existing code.
the range in the excel is "H3752":"L4990", so only in that range the cells are to be merged, and not in the entire worksheet.
kinds regards.
The below code should work:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Cells(Target.Row + Target.Rows.Count, Target.Item(1, 1).Column).ID = Target.Address
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Item(1, 1).ID <> "" Then
'Code for if row is deleted
Else
'Code for if row is inserted
If Target.Row >= 3752 And Target.Row <= 4990 Then
Range(Cells(Target.Row, "H"), Cells(Target.Row, "L")).MergeCells = True
Range("H" & Target.Row + 1).Resize(, 5).Merge
End If
End If
Target.Item(1, 1).ID = ""
Cells(Target.Row + Target.Rows.Count, Target.Item(1, 1).Column).ID = Target.Address
End Sub
To change what rows you are looking at you can change this line: If Target.Row >= 3752 And Target.Row <= 4990 Then If you are trying to change the columns you can change this letters in this section:
Range(Cells(Target.Row, "H"), Cells(Target.Row, "L")).MergeCells = True
Range("H" & Target.Row + 1).Resize(, 5).Merge
works like a charm! but if i secure the excel file i do get an error now : "1004 while executing : error defined by the application or object"
Related
I have 5 columns ((a)uptick, (b)downtick, (c)original, (d)current), and (e) Stored Value. All columns need to be a range of rows. When d2 changes I want to compare it to e2 and if d2>e2 then bump the counter in a2 by 1 (uptick), if d2<e2 then bump the counter in b2 (downtick). I have it working with many if and elseif statements but would rather use less code using variables for the range. To detect the changing cell I use "If Not Intersect (Target, Range("d2:d10")) Is Nothing Then...."
I cannot seem to figure out how to replace specific cell references with ranges. Any help would be most appreciated!
Sample Code below not using ranges yet.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("D2:D10")) Is Nothing Then
If Target.Value > Range("E2") Then
Range("A2") = Range("A2") + 1
Pause 2#
Range("E2") = Target.Value
ElseIf Target.Value < Range("E2").Value Then
Range("B2") = Range("B2") + 1
Pause 2#
Range("E2") = Target.Value
End If
End If
End Sub
I assume you want to change the cell value in the same row that the value was entered in column D, i.e. if D4 has been changed, then adjust A4 or B4. To do that, you need the row number of the changed cell. You can extract that with target.row. Throw that into a variable and use the variable instead of the row number in the Range() property.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("D2:D10")) Is Nothing Then
dim myRow as long
myRow = target.row
If Target.Value > Range("E" & myRow) Then
Range("A" & myRow) = Range("A" & myRow) + 1
Pause 2#
Range("E" & myRow) = Target.Value
ElseIf Target.Value < Range("E" & myRow).Value Then
Range("B" & myRow) = Range("B" & myRow) + 1
Pause 2#
Range("E" & myRow) = Target.Value
End If
End If
End Sub
You could use .Offset to get the same result. The following code assumes you're only interested in the range D2:D10 and aren't concerned if the value in column D equals the value in column E.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("D2:D10"), Target) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub
If Target > Target.Offset(, 1) Then
Target.Offset(, -3) = Target.Offset(, -3) + 1
Else
If Target < Target.Offset(, 1) Then
Target.Offset(, -2) = Target.Offset(, -2) + 1
End If
End If
End If
End Sub
I am trying to figure out how to simplify the code with no luck.
I managed to build a working code, which does the following:
1. If 'ja' is filled into cell 34
- in cell 35 the date appears
- in cell 36 the username appears
2. If the cell is empty, the content is cleared
Do you have any tips / can help me out?
Thank you very much.
This is the code I have so far:
'show date
If Target.Column = 34 Then
Select Case Target
Case "ja", "Ja": Target.Offset(0, 1) = Date
End Select
'show username
If Target.Column = 34 Then
Select Case Target
Case "ja", "Ja": Target.Offset(0, 2) = Application.UserName
End Select
End If
End If
' clear contents
Dim n As Long
If Target.Column = 34 Then
If IsEmpty(Cells(Target.Row, 34)) Then
Range("AI" & Target.Row & ":AJ" & Target.Row).ClearContents
End If
End If
End Sub
I think this would do it:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 34 Then
Select Case Target
Case "ja", "Ja"
Target.Offset(0, 1) = Date 'show date
Target.Offset(0, 2) = Application.UserName 'show username
Case vbNullString 'Clear contents
Range("AI" & Target.Row & ":AJ" & Target.Row).ClearContents
End Select
End If
End Sub
I think the code should be something like this, but I'm getting an error on this line where I am trying to handle the first and last names. Basically, I want to create a code in Column A, which is the first letter of the person's first name and first letter of the person's last name, concatenated with the row number. The row will be the active row (always Column A) and the first and last names will be stored in Column B.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub
On Error GoTo ErrHandler
Application.EnableEvents = False
If Target.Column = 1 Then
Target.Offset(0, 0).FormulaR1C1 = "=ROW()"
TV1 = Target.Offset(0, 0).FormulaR1C1
Target.Offset(0, 0).FormulaR1C1 = "=UPPER(LEFT(R[" & "=ROW()" & "]C[1],1)&MID(R[" & "=ROW()" & "]C[1],FIND("" "",R[" & "=ROW()" & "]C[1],1)+1,1))"
TV2 = Target.Offset(0, 0).FormulaR1C1
Target.Offset(0, 0).Value = TV2 & "-" & TV1
End If
End Sub
I don't like to avoid dealing with more than a single cell as the Target. It isn't hard to deal with multiple cells.
After disabling events and performing your processing, you are not turning them back on again. You code will only run once without manually turning events back on.
If you are putting first and last names into column B, shouldn't the processing be subject to column B and not column A?
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B")) Is Nothing Then
On Error GoTo ErrHandler
Application.EnableEvents = False
Dim trgt As Range
For Each trgt In Intersect(Target, Target.Parent.UsedRange, Columns("B"))
trgt = StrConv(Trim(trgt.Value2), vbProperCase)
If CBool(InStr(2, trgt.Value2, Chr(32))) Then
trgt.Offset(0, -1) = _
UCase(Left(trgt.Value2, 1)) & _
UCase(Mid(trgt.Value2, InStr(1, trgt.Value2, Chr(32)) + 1, 1)) & _
Format(trgt.Row, "000")
End If
Next trgt
End If
ErrHandler:
Application.EnableEvents = True
End Sub
I've added some trim and proper-case conversion to auto-correct the values being typed into column B.
In the following image, I copied the names from G5:G8 and pasted them into B2:B5.
I would do this differently. Why write formulas when you can do it simply in VBA?
I've made some annotations to your original code also:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub
Application.EnableEvents = False
' No error handler in your code
'On Error GoTo ErrHandler
' don't need to check if column 1 since we already did that and exited the sub if it was not
' If Target.Column = 1 Then
'Target.Offset(0,0) = Target
'Target.Offset(0, 0).FormulaR1C1 = "=ROW()"
'TV1 = Target.Offset(0, 0).FormulaR1C1
'Target.Offset(0, 0).FormulaR1C1 = "=UPPER(LEFT(R[" & "=ROW()" & "]C[1],1)&MID(R[" & "=ROW()" & "]C[1],FIND("" "",R[" & "=ROW()" & "]C[1],1)+1,1))"
'TV2 = Target.Offset(0, 0).FormulaR1C1
'Target.Offset(0, 0).Value = TV2 & "-" & TV1
'Just do the creation in VB
With Target
.Value = .Row & Left(.Offset(0, 1), 1) & Left(Split(.Offset(0, 1))(1), 1)
End With
'If you have more than two space-separated words in the name, then something like
Dim V As Variant
With Target
V = Split(.Offset(0, 1))
.Value = .Row & Left(V(0), 1) & Left(V(UBound(V)), 1)
End With
'Don't forget to reenable events
Application.EnableEvents = True
End Sub
Also, since the names are in Column B, why are you testing for a change in Column A? There could be reasons, but if there are not, it might be smoother to check for changes in column B.
I figured it out!!
If Target.Column = 1 Then
Target.Offset(0, 0).FormulaR1C1 = "=ROW()"
TV1 = Target.Value
Target.Offset(0, 0).FormulaR1C1 = "=UPPER(LEFT(RC[1],1)&MID(RC[1],FIND("" "",RC[1],1)+1,1))"
TV2 = Target.Value
Target.Value = TV2 & "-" & TV1
End If
I Have a worksheet in which we need to automate the number of column entries based on the number of units required.
The cells in each row have formulas based on input parameters and subtotals. The requirement is to insert defined number of columns based on the units required (can be input box or cell reference) which should result in copying all formulas and formats to all columns inserted. The inserted columns should be before the last three columns namely Total, Budget and Variance.
I have found the below code but this is not working for my example.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LC As Integer
Dim I As Integer
Application.ScreenUpdating = False
If Target.Address <> "$C$3" Then Exit Sub
If Target.Value = "" Or Target.Value = 0 Then MsgBox "Value must be superior to 0": Exit Sub
LC = Cells(2, Application.Columns.Count).End(xlToLeft).Column
If LC = 5 Then
If Target.Value = 1 Then
Exit Sub
Else
For I = 2 To Target.Value
Columns(4).Copy
Columns(I + 3).Insert Shift:=xlToRight
Cells(2, I + 3).Value = "Unit " & I
Cells(3, I + 3) = I
Next I
End If
Application.CutCopyMode = False
Exit Sub
End If
Range(Cells(2, 5), Cells(2, LC - 1)).EntireColumn.Delete
For I = 2 To Target.Value
Columns(4).Copy
Columns(I + 3).Insert Shift:=xlToRight
Cells(2, I + 3).Value = "Unit " & I
Cells(3, I + 3) = I
Next I
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Kindly help me with a solution to this problem.
Please let me know how I can send the worksheet for your reference.
Thanks,
Best regards,
Thomas
I have an Excel 2010 form. I am trying to change the row color based on several variables.
I do understand that this can be accomplished with conditional formatting and have got that to work, but cutting and pasting, as my users will likely do, kills the formatting. I was hoping that VBA would fix that. Possibly there is some other solution I am unaware of.
This is what I want to happen (the so called logic)
on Sheet3
Columns (a – w)
rows (2 – 10485)
upon a change in any field, $x2, or a past due date in $T2
if(AND($X2="Open",$T2<>"",$T2<=TODAY()) then all row red ($a2-$x2)
if(AND($X2="Open",$T2="",$T2>TODAY()) then all row white ($a2-$x2)
=$X2="Completed" then all row grey ($a2-$x2)
=$X2="Rescinded" then $X2 = orange and $A2 thru $W2 = grey
The x field will use a drop down and be either ( blank, open, completed, or rescinded )
This is the code I have tried to hobble together and failed with.....
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A2:X1048567")) Is Nothing Then Exit Sub
Select Case Cells(Target.Row, "X").Value
Case "Open"
If Cells(Target.Row, "T").Value <> "" And T2 <= TODAY() Then 'Range(Cells(Target.Row, "A"), Cells(Target.Row, "F")).Interior.ColorIndex = 3
Else
Range(Cells(Target.Row, "A"), Cells(Target.Row, "F")).Interior.ColorIndex = x1None
End Select
Case "Completed"
Range(Cells(Target.Row, "A"), Cells(Target.Row, "F")).Interior.ColorIndex = 15
Case "Rescinded"
Range(Cells(Target.Row, "A"), Cells(Target.Row, "F")).Interior.ColorIndex = 15
Range(Cells(Target.Row, "A"), Cells(Target.Row, "F")).Interior.ColorIndex = 46
Case ""
Range(Cells(Target.Row, "A"), Cells(Target.Row, "F")).Interior.ColorIndex = xlNone
End Select
End Sub
There were a few discrepancies between what you described and what your code sample indicated so I went with the former.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:X")) Is Nothing Then
On Error GoTo safe_exit
Application.EnableEvents = False
Dim rw As Long, rng As Range
For Each rng In Intersect(Target, Range("A:X"))
rw = rng.Row
If rw > 1 Then
Select Case LCase(Cells(rw, "X").Value2)
Case "open"
If Cells(rw, "T").Value <> "" And Cells(rw, "T").Value <= Date Then
Cells(rw, "A").Resize(1, 24).Interior.ColorIndex = 3
Else
Cells(rw, "A").Resize(1, 24).Interior.Pattern = xlNone
End If
Case "completed"
Cells(rw, "A").Resize(1, 24).Interior.ColorIndex = 15
Case "rescinded"
Cells(rw, "A").Resize(1, 23).Interior.ColorIndex = 15
Cells(rw, "X").Interior.ColorIndex = 46
Case Else
Cells(rw, "A").Resize(1, 24).Interior.Pattern = xlNone 'use pattern to turn off interior fill
End Select
End If
Next rng
End If
safe_exit:
Application.EnableEvents = True
End Sub
That should also handle multiple entries like those received from pasting a number of values into the sheet. By 'white' I assumed that you meant to remove any fill color, not actually provide a white fill color.