Copy cell value to a range of cells - vba

I'm new to VBA and I am trying to copy values from one cell to multiple cells when its value changes.
The value of A2 is constantly changing and when that happens I want that value to be copied to cells C2:C21 (and then eventually to cells D2:D21)
Here is an example of what I would like to achieve:
http://i.stack.imgur.com/xJZyZ.jpg
So far I wrote this code:
Sub Worksheet_Change(ByVal Target As Range)
For i = 0 To 19
If Not Intersect(Target, Range("AS2")) Is Nothing Then
Cells(Target.Row + i, 58).Value = Cells(Target.Row, 45).Value
End If
Next i
End Sub
but this only copies one single value of A2 to all the cells C2 to C22.
May anyone help me write this code properly?

Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("AS2")) Is Nothing Then
For CurCol = 3 to 4
For CurRow = 2 to 21
If Cells(CurRow, CurCol).Value = "" Then
Cells(CurRow, CurCol).Value = Target.Value
Exit Sub
EndIf
Next CurRow
Next CurCol
End If
End Sub

I guess this is what you're after:
Option Explicit
Sub Worksheet_Change(ByVal Target As Range)
Dim nVals As Long
If Not Intersect(Target, Range("A2")) Is Nothing Then
With Range("C2:D21")
nVals = WorksheetFunction.CountA(.Cells)
If nVals = .Count Then Exit Sub
Application.EnableEvents = False
On Error GoTo exitsub
.Cells(nVals Mod .Rows.Count + 1, IIf(nVals >= .Rows.Count, 2, 1)).Value = Target.Value
End With
End If
exitsub:
Application.EnableEvents = True
End Sub

Related

Have more than one Worksheet_Change in a Worksheet

I am looking to limit my workbook users to 1000 characters over a range of cells (Example: A5:A30).
In other words limit the total characters in the range A5:A30 to 1000 characters.
When a user fills in a cell that sends the range over the 1000 character limit, it will call Application.undo which should just remove the last text that they added.
However since I have another Private Sub Worksheet_Change(ByVal Targe As Range) on the worksheet, it causes a bug.
Below is both Worksheet_Change subs. Both use the same cells.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim charCount As Long
If Not Intersect(Target, Range("E6,E11,E16")) Is Nothing Then
Dim arrValues As Variant
arrValues = Range("E6,E11,E16").Value2
Dim i As Long
Dim tempSplit As Variant
Dim j As Long
For i = LBound(arrValues) To UBound(arrValues)
tempSplit = Split(arrValues(i, 1), " ")
For j = LBound(tempSplit) To UBound(tempSplit)
charCount = charCount + Len(tempSplit(j))
Next j
Next i
End If
If charCount > 1000 Then
Application.Undo
MsgBox "Adding this exceeds the 1000 character limit"
End If
If Not Intersect(Target, Range("D6")) Is Nothing Then
If Target.Value2 = "Material" Then
'assumes the comment cell is one column to the right
Target.Offset(0, 1) = "**"
End If
End If
If Not Intersect(Target, Range("D7")) Is Nothing Then
If Target.Value2 = "Material" Then
'assumes the comment cell is one column to the right
Target.Offset(-1, 1) = "**"
End If
End If
If Not Intersect(Target, Range("D8")) Is Nothing Then
If Target.Value2 = "Material" Then
Target.Offset(-2, 1) = "**"
End If
End If
End Sub
Is there a way around this so I can have two Worksheet_Change on the same worksheet?
You cannot have two Worksheeet_Change events in one sheet. But, one is quite enough:
Private Sub Worksheet_Change(ByVal Target As Range)
Select Case True
Case Not Intersect(ActiveCell, Range("A5:A30")) Is Nothing
DoThingOne
Case Not Intersect(ActiveCell, Range("B5:B30")) Is Nothing
DoThingTwo
End Select
End Sub
Private Sub DoThingOne()
Debug.Print "THING ONE"
End Sub
Private Sub DoThingTwo()
Debug.Print "THING TWO"
End Sub
How about this revision using Vityata's idea?
Private Sub Worksheet_Change(ByVal Target As Range)
Select Case True
Case Not Intersect(Target, Range("E6,E11,E16")) Is Nothing
Dim charCount As Long
Dim arrValues As Variant
arrValues = Range("E6,E11,E16").Value2
Dim i As Long
Dim tempSplit As Variant
Dim j As Long
For i = LBound(arrValues) To UBound(arrValues)
tempSplit = Split(arrValues(i, 1), " ")
For j = LBound(tempSplit) To UBound(tempSplit)
charCount = charCount + Len(tempSplit(j))
Next j
Next i
If charCount > 1000 Then
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
MsgBox "Adding this exceeds the 1000 character limit"
End If
Case Not Intersect(Target, Range("D6")) Is Nothing
If Target.Value2 = "Material" Then
'assumes the comment cell is one column to the right
Target.Offset(0, 1) = "**"
End If
Case Not Intersect(Target, Range("D7")) Is Nothing
If Target.Value2 = "Material" Then
'assumes the comment cell is one column to the right
Target.Offset(-1, 1) = "**"
End If
Case Not Intersect(Target, Range("D8")) Is Nothing
If Target.Value2 = "Material" Then
Target.Offset(-2, 1) = "**"
End If
End Select
End Sub

Excel VBA to insert duplicate row below based on drop down menu

I would like to add to the following VBA code, so that when "Did not attend" is selected from dropdown menu a duplicate row is ALSO inserted below the current row within the current worksheet "Details".
Private Sub Worksheet_Change1(ByVal Target As Range)
'Determine if change was made to a single cell in Column E
If Target.Column = 5 And Target.Cells.Count = 1 Then
'Determine if Did not attend was chosen
If Target = "Did not attend" Then
'If Yes...
''Disable Events
Application.EnableEvents = False
''Insert a row below
ActiveCell.Offset(1).EntireRow.Insert
''Copy, Paste
Rows(Target.Row).EntireRow.Copy _
Destination:=Sheets("Non Attendance").Range("A" & nxtRw)
''Re-enable Events
Application.EnableEvents = True
End If
End If
End Sub
This code should do what you want. Please try it.
Private Sub Worksheet_Change(ByVal Target As Range)
' 22 Jan 2018
Dim Rng As Range
Set Rng = Range(Cells(2, "E"), Cells(Rows.Count, "E").End(xlUp))
Debug.Print Target.Address
' Determine if change was made in Column E, below row 1 and above last row
If Not Application.Intersect(Target, Rng) Is Nothing Then
With Target
On Error Resume Next
If .Cells.Count = 1 Then ' if change was in a single cell
'Determine if Did not attend was chosen
If StrComp(.Value, "Did not attend", vbTextCompare) = 0 Then
' If Yes...
Application.EnableEvents = False
.Offset(1).EntireRow.Insert ' Insert a row below
With Worksheets("Non Attendance")
Set Rng = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
End With
' Copy, Paste
Rows(.Row).EntireRow.Copy Destination:=Rng
Application.EnableEvents = True
End If
End If
End With
End If
End Sub

How to prefix cell with 0, dependant on character length

Private Sub Worksheet_Change(ByVal Target As Range)
If Len(Target) = 8 Then
Exit Sub
End If
If Range("AF1:AF1000").Value = "Q" Then
Exit Sub
End If
On Error Resume Next
Application.EnableEvents = False
If Target.Column = 30 Then
lTarget = Len(Target)
Target.NumberFormat = "#"
For i = 1 To 8 - lTarget
Target.Value = "0" & Target.Value
Next
End If
Application.EnableEvents = True
End Sub
I'm trying to get this to basically when putting the information into a certain cell, if you put any less that 8 digits in, it will prefix it with '0 until it is 8 which is does, but now i want to adapt it so that it doesn't do it if a certain cell has the text "Q" in it, its not working when i do this how ever, little help?
EDIT: to make this easier the whole AF thing... its the entire AF column not just 1 to 1000 so how do i change that with what i have so far... probably need to re-write the whole thing..lol :(
If you mean it should check column AF on the same row for a Q, try this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rCell As Range
If Not Intersect(Target, Me.Columns(30)) Is Nothing Then
On Error Resume Next
Application.EnableEvents = False
For Each rCell In Intersect(Target, Me.Columns(30)).Cells
Select Case Len(rCell.Value)
Case 0, 8
' ignore if 8 characters or blank
Case Else
If Strings.UCase$(Cells(rCell.Row, "AF").Value) <> "Q" Then
rCell.NumberFormat = "#"
rCell.Value = VBA.Right$("0000000" & rCell.Value, 8)
End If
End Select
Next rCell
End If
Application.EnableEvents = True
End Sub

Creating a Timestamp VBA

Need Help with this Macro:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 Then
Application.EnableEvents = False
Cells(Target.Row, 3).Value = Date + Time
Application.EnableEvents = True
End If
End Sub
Sub DeleteCells()
For Each Cell In Range("B3:B25")
If IsBlank(Cell.Value) Then
Cell.Offset(0, 1).Clear
End If
Next
End Sub
The purpose of this macro is to create a timestamp. First macro works fine. If anything from row B is filled in, a timestamp will be created in row C. However, the delete cells function isn't working. I want it so that if someone deletes a cell in row B, the timestamp will also be deleted.
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range
'anything in ColB?
Set rng = Application.Intersect(Me.Columns(2), Target)
If rng Is Nothing Then Exit Sub 'nothing to process...
Application.EnableEvents = False
'could be >1 cell, so loop over them...
For Each c In rng.Cells
'skip any cells with errors
If c.Row>=3 And Not IsError(c.Value) Then '<<edit
c.EntireRow.Cells(3).Value = _
IIf(Len(c.Value) > 0, Now, "")
End If
Next c
Application.EnableEvents = True
End Sub

Emptying specific cells in the same row of an amended cell

I am relatively new to VBA.
Below is my code that works on just row 2.
Option Explicit
Public precedent
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.[D2]) Is Nothing Then
If Me.precedent <> Me.[D2].Value Then
Me.[F2] = ""
Me.[H2] = ""
Me.precedent = Me.[D2].Value
End If
End If
End Sub
I would like this code to run on every row except row 1 as this is my header.
How do I do this? Would I use a loop?
It shouldn't be so complicated. Just check Target.Row and Target.Column. If the former is greater than 1 and the latter is equal to 4, trigger whatever action you want.
Modify the following code accordingly.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row > 1 And Target.Column = 4 Then
Range("F" & Target.Row) = vbNullString
Range("H" & Target.Row) = vbNullString
End If
End Sub
Let us know if this helps.
You wouldn't have to use a loop. Since you want to omit the first row, you should set a range that you want this code to fire when it is modified. Currently, you are checking it against D2 only. When your If statement is checking for your entire range, you can then use Target as the specific cell that was changed (instead of using D2.)
Here's some code that should do what you want:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rangeToCheck As Range
rangeToCheck = Range(Cells(2,4),Cells(Application.ActiveSheet.UsedRange.Rows.Count,4)) 'If your range isn't dynamic, you could put static numbers here
If Not Intersect(Target, rangeToCheck) Is Nothing Then 'Now checks against all of Column D, omitting Row 1
If Target.precedent <> Target.Value Then
Target.Offset(0,2).Value = "" 'Clear Column F in Target Row
Target.Offset(0,4).Value = "" 'Clear Column H in Target Row
Target.precedent = Target.Value
End If
End If
End Sub
Below is code that will skip row 1. Note the .Row and .Column properties of 'Target'
Option Explicit
Public precedent
Private Sub Worksheet_Change(ByVal Target As Range)
Debug.Print Target.Column
Debug.Print Target.Row
If Target.Row <> 1 Then
If Not Intersect(Target, Me.[D2]) Is Nothing Then
If Me.precedent <> Me.[D2].Value Then
Me.[F2] = ""
Me.[H2] = ""
Me.precedent = Me.[D2].Value
End If
End If
End If
End Sub
I think you need this one:
Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 4 Then Exit Sub
If Me.Cells(Target.Row, 4) = "" Then
Me.Cells(Target.Row, 6) = ""
Me.Cells(Target.Row, 8) = ""
End If
End Sub