i have 2 Private Sub Worksheet_change(ByVal Target As Range) codes that work on their own. i need them to work in the same sheet. whenever i do this the 2nd code does not run. how do i merge these please!!?
Code 1:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, cel As Range
Set rng = Intersect(Target, Range([H2], Cells(Rows.Count,
"H").End(xlUp)))
If rng Is Nothing Then Exit Sub
Application.EnableEvents = False
rng.Offset(, 1).FormulaR1C1 = "=IF(RC[-1]<>"""",R1C[6] & ""-"" &" &
"TEXT(COUNTA(R2C[-1]:RC[-1]),""0000"") & ""-"" & R1C[7],"""")"
Application.EnableEvents = True
End Sub
Code 1 is using P1 and O1 to populate an automatic number in column I if information is provided in H
Code 2:
Private Sub Move_blanks_To_Bottom(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Target.Column <> 9 Then Exit Sub
Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, 11).Sort
key1:=Range("I1"), order1:=xlAscending, Header:=xlYes
End Sub
Code 2 is using column I and sorting the values so if there is a value in I it move the row to the next available line where column I is completed effectively if cell I is blank the row is moved to the bottom.
as i understand you cannot run 2 private sub codes so how would i run both of these on the same sheet at the same time?
thanks!
Because your first code exits (Exit Sub) when it fails that Intersect, then you have to call your second subroutine above that If statement. You'll have to pass it the Target as well like:
Call Move_blanks_To_Bottom(Target)
However, I think a rewrite might be best. Instead of exiting the subroutine all over the place, instead place relevant bits of code inside If statements so your routine can run to completion and exit gracefully:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
'Do logic for this first range
Dim rng As Range
rng = Range([H2], Cells(Rows.Count, "H").End(xlUp)))
If Not Intersect(rng, Target) Is Nothing Then
rng.Offset(, 1).FormulaR1C1 = "=IF(RC[-1]<>"""",R1C[6] & ""-"" &" & "TEXT(COUNTA(R2C[-1]:RC[-1]),""0000"") & ""-"" & R1C[7],"""")"
End If
'now do logic for the second range (move_blanks_to_bottom)
If Target.CountLarge = 1 And Target.Column = 9 Then
Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, 11).Sort key1:=Range("I1"), order1:=xlAscending, Header:=xlYes
End If
Application.EnableEvents = True
End Sub
Related
I have 2 private subs that have been merged into the code below. the 2nd part of the code i need to define the logic for the range. The issue i am facing is my second code does not specify a range so i am unsure on how to define the range? and my VBA knowledge is not that great! can someone help me enter this information?
The Codes before merging are:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, cel As Range
Set rng = Intersect(Target, Range([H2], Cells(Rows.Count,
"H").End(xlUp)))
If rng Is Nothing Then Exit Sub
Application.EnableEvents = False
rng.Offset(, 1).FormulaR1C1 = "=IF(RC[-1]<>"""",R1C[6] & ""-"" &" &
"TEXT(COUNTA(R2C[-1]:RC[-1]),""0000"") & ""-"" & R1C[7],"""")"
Application.EnableEvents = True
End Sub
Code 1 is using P1 and O1 to populate an automatic number in column I if information is provided in H Code 2:
Private Sub Move_blanks_To_Bottom(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Target.Column <> 9 Then Exit Sub
Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, 11).Sort
key1:=Range("I1"), order1:=xlAscending, Header:=xlYes
End Sub
Code 2 is using column I and sorting the values so if there is a value in I it moves the row to the next available line where column I is completed effectively if cell I is blank the row is moved to the bottom.
The merged code is:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
'Do logic for this first range
Dim rng As Range, cel As Range
Set rng = Intersect(Target, Range([H2], Cells(Rows.Count,
"H").End(xlUp)))
If Not Intersect(rng, Target) Is Nothing Then
rng.Offset(, 1).FormulaR1C1 = "=IF(RC[-1]<>"""",R1C[6] & ""-"" &" &
"TEXT(COUNTA(R2C[-1]:RC[-1]),""0000"") & ""-"" & R1C[7],"""")"
End If
'now do logic for the second range (move_blanks_to_bottom)
'2nd LOGIC HERE
If Target.CountLarge = 1 And Target.Column = 9 Then
Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, 11).Sort
key1:=Range("I1"), order1:=xlAscending, Header:=xlYes
End If
Application.EnableEvents = True
End Sub
Thank you!
Your sorting command is fine though it is pretty complicated because it compresses a series of operations in one command. With this command you sort a range from column A to column K (=11) and from row 1 to last used row, with header. You could split this command with these simpler ones:
Dim lastrow As Long
Dim r As Range
lastrow = Range("A" & Rows.Count).End(xlUp).Row ' find row of last non-blank cell in column A
Set r = Range("A1").Resize(lastrow, 11) ' set the exact data range
r.Sort key1:=Range("I1"), order1:=xlAscending, Header:=xlYes
but this will do the same as in your code 2.
You might need to know that if you break the command into 2 lines you need to terminate the line with an _ like this:
Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, 11).Sort _
key1:=Range("I1"), order1:=xlAscending, Header:=xlYes
otherwise the compiler will treat them as separate commands and will drop a Syntax error message.
I am having problems with a "Worksheet_Change" sub that copies and pastes the whole row into a second worksheet ("Completed") when the column "P" takes on the value "x". It reads like this:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
'If Cell that is edited is in column P and the value is x then
If Target.Column = 16 And Target.Value = "x" Then
'Define last row on completed worksheet to know where to place the row of data
LrowCompleted = Sheets("Completed").Cells(Rows.Count, "A").End(xlUp).Row
'Copy and paste data
Range("A" & Target.Row & ":P" & Target.Row).Copy Sheets("Completed").Range("A" & LrowCompleted + 1)
'Delete Row from Project List
Range("A" & Target.Row & ":P" & Target.Row).Delete xlShiftUp
End If
Application.EnableEvents = True
End Sub
The sub itself works fine but if I copy and paste anywhere in the worksheet, the sub is activated and the row into which I paste is send to my "Completed" sheet.
I have played around with the "if-clause" without any luck so far. E.g.:
If Not Target.Column = 16 And Target.Value = "x" Is Nothing Then
I fear I am missing the obvious and I am grateful for any help.
Thanks and regards
PMHD
If you are concerned with muliple targets, deal with them; don't discard them.
Private Sub Worksheet_Change(ByVal Target As Range)
If not intersect(target, range("p:p")) is nothing then
on error goto meh
Application.EnableEvents = False
dim t as range, lrc as long
lrc = workSheets("Completed").Cells(Rows.Count, "A").End(xlUp).Row + 1
for each t in intersect(target, range("p:p"))
if lcase(t.Value2) = "x" Then
intersect(columns("A:P"), t.rows(t.row)).Copy _
destination:=workSheets("Completed").cells(lrc , "A")
lrc = lrc+1
'Delete Row from Project List
intersect(columns("A:P"), t.rows(t.row)).Delete xlShiftUp
end if
next t
End if
meh:
Application.EnableEvents = true
end sub
Thanks, Jeeped.
The problem arose due to Target referring to multiple cells. It was fixed by excluding cases where Target.Count > 1.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
'Exclude all cases where more than one cell is Target
If Target.Count > 1 Then
'If Cell that is edited is in column P and the value is x then
ElseIf Target.Column = 16 And Target.Value = "x" Then
'Define last row on completed worksheet to know where to place the row of data
LrowCompleted = Sheets("Completed").Cells(Rows.Count, "A").End(xlUp).Row
'Copy and paste data
Range("A" & Target.Row & ":P" & Target.Row).Copy Sheets("Completed").Range("A" & LrowCompleted + 1)
'Delete Row from Project List
Range("A" & Target.Row & ":P" & Target.Row).Delete xlShiftUp
End If
Application.EnableEvents = True
End Sub
I'm using Private Sub Worksheet_Change(ByVal Target As Range) to react to a changes in Range("AV9:AV" & lastrow) in each of this cells is a dropdown list which is defined as follow:
Dim lastrow2 As Long
Dim lastcell As Long
lastrow2 = Tabelle3.Range("A" & Rows.Count).End(xlUp).Offset(8).Row
lastcell = Tabelle3.Range("AH1048576").End(xlUp).Row
For Each Cell In Tabelle3.Range(Tabelle3.Cells(9, 48), Tabelle3.Cells(lastcell, 48))
If Cell = "" Then
Dim MyList(2) As String
MyList(0) = "Relevant"
MyList(1) = "For Discussion"
MyList(2) = "Not Relevant"
With Tabelle3.Range("AV9:AV" & lastrow2).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=Join(MyList, Application.International(xlListSeparator))
End With
End If
Next
Those lines are incorporated into a macro which fills Tabelle3with data and all necessary functions, such as the dropdown field.
The Private Sub Worksheet_Change(ByVal Target As Range) is defined as follow:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastrow As Long
lastrow = Tabelle3.Range("A" & Rows.Count).End(xlUp).Offset(8).Row
On Error Resume Next
If Not Intersect(Target, Range("AV9:AV" & lastrow)) Is Nothing And Target.Value = "Relevant" Or Target.Value = "For Discussion" Then
Application.CutCopyMode = False
Cells(Target.Row, "A").Resize(, 57).Copy
Tabelle14.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Tabelle14.Range("A" & Rows.Count).End(xlUp).PasteSpecial xlPasteFormats
Tabelle14.Range("A" & Rows.Count).End(xlUp).PasteSpecial xlPasteColumnWidths
Application.CutCopyMode = False
End If
If Not Intersect(Target, Range("AV9:AV" & lastrow)) Is Nothing And Target.Value <> "" Then
Cells(Target.Row, "A").Resize(, 2).Copy
Tabelle10.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
'//Delete all duplicate rows
Set Rng = Tabelle10.UsedRange
Rng.RemoveDuplicates Columns:=Array(1)
End Sub
As you can see the first part of the Private Sub Worksheet_Change(ByVal Target As Range) 'should' only be executed If in a dropdown field in Range("AV9:AV" & lastrow) the option 'Relevant' or 'For Discussion' is selected and the second part If anything is selceted , therefore I have used Target.Value <> "". This is principally working fine but one bug occurs.
If I insert the data to Tabelle3 through the already mentioned macro, it seems the Private Sub Worksheet_Change(ByVal Target As Range) is then automatically executed for row 9 in Tabelle3and I can find its data in Tabelle14 and Tabelle10 as defined.
Does someone know what's going on here?
Try making these changes:
Option Explicit
Public Sub SetTabelle3Validation()
Const V_LIST = "Relevant,For Discussion,Not Relevant"
Dim ws As Worksheet: Set ws = Tabelle3
Dim lr As Long: lr = ws.Range("AV" & ws.Rows.Count).End(xlUp).Row
Dim app As Application: Set app = Application
Dim fc As Range
If lr > 9 Then
Set fc = ws.Range(ws.Cells(9, "AV"), ws.Cells(lr, "AV"))
fc.Validation.Delete
fc.AutoFilter Field:=1, Criteria1:="<>"
If fc.SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
app.EnableEvents = False
app.ScreenUpdating = False
With fc.SpecialCells(xlCellTypeVisible).Validation
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=Join(Split(V_LIST, ","), app.International(xlListSeparator))
End With
app.ScreenUpdating = True
app.EnableEvents = True
End If
fc.AutoFilter
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr As Long: lr = Me.Rows.Count
Dim lrT3 As Long: lrT3 = Me.Range("A" & lr).End(xlUp).Offset(8).Row
Dim app As Application: Set app = Application
Dim inAV As Boolean
inAV = Not Intersect(Target, Me.Range("AV9:AV" & lrT3)) Is Nothing
With Target
If .Cells.CountLarge > 1 Or Not inAV Or Len(.Value) = 0 Then Exit Sub
app.EnableEvents = False
If .Value = "Relevant" Or .Value = "For Discussion" Then
Me.Cells(.Row, "A").Resize(, 57).Copy
With Tabelle14.Range("A" & lr).End(xlUp).Offset(1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteColumnWidths
End With
Tabelle14.UsedRange.RemoveDuplicates Columns:=Array(1)
End If
Me.Cells(.Row, "A").Resize(, 2).Copy
With Tabelle10
.Range("A" & lr).End(xlUp).Offset(1).PasteSpecial xlPasteValues
.UsedRange.RemoveDuplicates Columns:=Array(1)
End With
app.CutCopyMode = False
app.EnableEvents = True
End With
End Sub
In SetTabelle3Validation()
Replace For loop with AutoFilter for speed
Turn Application.EnableEvents Off to stop triggering Worksheet_Change() (then back On)
In Worksheet_Change()
Exit the Sub if pasting multiples values, Target is not in col AV, or is empty
Else (Target is in col AV, and not empty)
Turn Application.EnableEvents Off
If Target value is "Relevant" Or "For Discussion", update Tabelle14
Else (Target value is "Not Relevant"), update Tabelle10
Turn Application.EnableEvents On
Assumptions
All objects starting with Tabelle are the Code Names of other sheets
Worksheet_Change() belongs to Tabelle3
My code is limited to work fine only with first empty cell found, the problem starts is that if finds the next two or more empty cells because it loops a bit (I can handle with that), but if it finds empty cells and next finds cells with data again, it totally fails.
Private Sub Worksheet_Change(ByVal Target As Range)
firstRow = 7
lastrow = Sheets("Datos del Proyecto").Range("F" & Rows.Count).End(xlUp).row
i = firstRow
Do Until i > lastrow
If Sheets("Datos del Proyecto").Range("G" & i).Value Like "" Then
Sheets("Datos del Proyecto").Range("F" & i).ClearContents
End If
i = i + 1
Loop
Screenshot:
Since the code is placed inside "Datos del Proyecto" sheet, in Worksheet_Change event, there is no need to reference it in the code all the time, as it is the default sheet.
Using Application.EnableEvents = False will prevent the code to exit and re-enter the Sub as you ClearContents each iteration inside the For loop.
Code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long, i As Long
' disable worksheet events >> will prevent the endless loop you got
Application.EnableEvents = False
' find last row in Column F
LastRow = Cells(Rows.Count, "F").End(xlUp).Row
' loop through all rows from row 7 until last row
For i = 7 To LastRow
If IsEmpty(Range("G" & i)) Or Range("G" & i).Value = "" Then
Range("F" & i).ClearContents
End If
Next i
Application.EnableEvents = True
End Sub
You can ass an option to your Sub , to make it run only if the change occurred in certain Range by adding these 3 lines in the beginning of the code:
Dim WatchRange As Range
' check only if cells changed are in Column G
Set WatchRange = Columns("G:G")
If Not Intersect(Target, WatchRange) Is Nothing Then
#Shai_Rado answer:
'Option Explicit <-- I needed to disable to make it work.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long, i As Long
'Dim WatchRange As Range <-- I needed to disable to make it work.
'Set WatchRange = Columns("G:G") <-- I needed to disable to make it work.
'If Not Intersect(Target, WatchRange) Is Nothing Then <-- I needed to disable to make it work.
Application.EnableEvents = False
LastRow = Cells(Rows.Count, "F").End(xlUp).row
For i = 7 To LastRow
If IsEmpty(Range("G" & i)) Or Range("G" & i).Value = "" Then
Range("F" & i).ClearContents
End If
Next i
Application.EnableEvents = True
End Sub
The one I proposed with the help lines:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Application.EnableEvents = False
firstRow = 7
lastrow = Sheets("Datos del Proyecto").Range("F" & Rows.Count).End(xlUp).row
i = firstRow
Do Until i > lastrow
If Sheets("Datos del Proyecto").Range("G" & i).Value Like "" Then
Sheets("Datos del Proyecto").Range("F" & i).ClearContents
End If
i = i + 1
Loop
Application.EnableEvents = True
End Sub
I am wondering if it is possible to call a private Sub worksheet_Change(ByVal Target As Range) type of sub from another public sub? I know that you can't really 'call' the sub but Run it, however my attempts at running the sub doesn't seem to work. This is what I have tried:
Sub AccessTransfer()
Range("A1:F1").Select
Selection.Copy
Sheets("Sheet2").Select
ActiveSheet.Paste
ActiveCell.Offset(0, 6).Value = "Oven"
Range("A65536").End(xlUp).Offset(1, 0).Select
Run.Application "Private Sub Worksheet_Change(ByVal Target As Range)"
Sheets("Sheet1").Select
Application.CutCopyMode = False
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Application.CountIf(Range("A:A"), Target) > 1 Then
MsgBox "Duplicate Entry", vbCritical, "Remove Data"
Target.Value = ""
End If
Range("A65536").End(xlUp).Offset(1, 0).Select
End Sub
Any help or suggestions on how to fix my problem would be most appreciated.
With Sheets("Sheet2").Range("A65536").End(xlUp).Offset(1, 0)
.Value = .Value
End With
will trigger the Event, but the Paste should already have done that...
EDIT: As commenters have pointed out, there are other issues with your code: this should be something like what you want to do -
Sub AccessTransfer()
Dim shtSrc As Worksheet, shtDest As Worksheet
Dim v, c As Range
Set shtSrc = ActiveSheet
Set shtDest = ThisWorkbook.Sheets("Sheet2")
v = shtSrc.Range("A1").Value 'value to check...
If Application.CountIf(shtDest.Range("A:A"), v) > 0 Then
MsgBox "Value '" & v & "' already exists!", vbCritical, "Can't Transfer!"
Else
'OK to copy over...
Set c = shtDest.Range("A65536").End(xlUp).Offset(1, 0)
shtSrc.Range("A1:F1").Copy c
c.Offset(0, 6).Value = "oven"
End If
Application.CutCopyMode = False
End Sub
There are a couple of things wrong with your code.
You may be making a change (e.g. Target.Value = "") in the Worksheet_Change which will trigger another event.
You haven't isolated Target to column A and have not dealt with more than a single cell being Target.
Module1 code sheet:
Sub AccessTransfer()
With Worksheets("Sheet2")
Worksheets("Sheet1").Range("A1:F1").Copy _
Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
'Sheet2's Worksheet_Change has been triggered right here
'check if the action has been reversed
If Not IsEmpty(.Cells(.Rows.Count, "A").End(xlUp)) Then
'turn off events for the Oven value write
Application.EnableEvents = False
.Cells(.Rows.Count, "A").End(xlUp).Offset(0, 6) = "Oven"
'turn events back on
Application.EnableEvents = True
End If
End With
End Sub
Sheet2 code sheet:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A")) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
Dim c As Long, rngs As Range
Set rngs = Intersect(Target, Range("A:A"))
For c = rngs.Count To 1 Step -1
If Application.CountIf(Columns("A"), rngs(c)) > 1 Then
MsgBox "Duplicate Entry in " & rngs(c).Address(0, 0), _
vbCritical, "Remove Data"
rngs(c).EntireRow.Delete
End If
Next c
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub