I would like to have two private sub as below (maybe more) in one sheet.
Each one works separately, but when I have both, only first one works. Could you please help me out.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Me.Range("f6:G19, j6:m19, f22:G35, j22:j35, L22:M35")) Is Nothing Then Exit Sub
If Not Target.MergeCells Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Else
If IsEmpty(Target.Cells(1, 1)) Then Exit Sub
End If
Cancel = True
Dim Lastrow As Long
Lastrow = Sheets("ShoppingCart").Cells(Rows.Count, "C").End(xlUp).Row + 1
Target.Cells(1, 1).Copy Sheets("ShoppingCart").Cells(Lastrow, 3)
End Sub
and
Private Sub Worksheet_BeforeDoubleClick_B(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Me.Range("h24:h25, h8:h9")) Is Nothing Then Exit Sub
If Not Target.MergeCells Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Else
If IsEmpty(Target.Cells(1, 1)) Then Exit Sub
End If
Cancel = True
Dim Lastrow As Long
Lastrow = Sheets("ShoppingCart").Cells(Rows.Count, "C").End(xlUp).Row + 1
Target.Cells(1, 1).Copy Sheets("ShoppingCart").Cells(Lastrow, 3)
Sheets("ShoppingCart").Cells(Lastrow + 1, 3).Value = "148H3124"
End Sub
thank you so much in advance.
Event handlers have specific names, it isn't recognizing the second sub as an event handler it just considers that a sub that happens to have a name that looks similar to the first one. You can either rename both and then create a new event sub and call them from that or combine them into a single sub.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
dblclick_a target, cancel
dblclick_b target, cancel
end sub
Private Sub dblclick_a(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Me.Range("f6:G19, j6:m19, f22:G35, j22:j35, L22:M35")) Is Nothing Then Exit Sub
If Not Target.MergeCells Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Else
If IsEmpty(Target.Cells(1, 1)) Then Exit Sub
End If
Cancel = True
Dim Lastrow As Long
Lastrow = Sheets("ShoppingCart").Cells(Rows.Count, "C").End(xlUp).Row + 1
Target.Cells(1, 1).Copy Sheets("ShoppingCart").Cells(Lastrow, 3)
End Sub
Private Sub dblclick_b(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Me.Range("h24:h25, h8:h9")) Is Nothing Then Exit Sub
If Not Target.MergeCells Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Else
If IsEmpty(Target.Cells(1, 1)) Then Exit Sub
End If
Cancel = True
Dim Lastrow As Long
Lastrow = Sheets("ShoppingCart").Cells(Rows.Count, "C").End(xlUp).Row + 1
Target.Cells(1, 1).Copy Sheets("ShoppingCart").Cells(Lastrow, 3)
Sheets("ShoppingCart").Cells(Lastrow + 1, 3).Value = "148H3124"
End Sub
Related
Hi how can i add both of these codes to 1 worksheet ?
The code auto copies data from 1 sheet to another
Thanks
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "y" Then
With Target.EntireRow
.Copy
Sheets("sheet9").Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlValues
End With
Application.CutCopyMode = False
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "b" Then
With Target.EntireRow
.Copy
Sheets("sheet10").Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlValues
End With
Application.CutCopyMode = False
End If
End If
End Sub
Your two subs do essentially the same thing, so you only need one:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As string
If Target.Column = 2 And Target.Cells.Count = 1 Then
Select Case LCase(Target.Value)
Case "y": ws = "Sheet9"
Case "b": ws = "Sheet10"
End select
If ws <> "" Then
Thisworkbook.sheets(ws).cells(rows.count,1).end(xlUp).offset(1,0).Entirerow.value = _
Target.EntireRow.Value
End If
End If
End Sub
Requirement - compare two rows , if found duplicate row ,display popup of "duplicate rows" and wouldn't proceed to next cell.. this code is not working as it is comparing column.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastRow As Long, j As Long
If Not Intersect(Target, Columns("G:L")) Is Nothing Then
If Target.Value <> "" Then
lastRow = Cells(Rows.Count, Target.Column).End(xlUp).Row
For j = 1 To lastRow
If Cells(j, Target.Column).Value = Target.Value And j <> Target.Row Then
MsgBox "row having same value"
Target.Clear: Target.Select
Exit For
End If
Next j
End If
End If
End Sub
You don't have to loop. You can use the excel function CountIf
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.CountLarge > 1 Then Exit Sub
If Not Intersect(Target, Columns("G:L")) Is Nothing Then
If Target.Value <> "" Then
If Application.WorksheetFunction.CountIf(Columns(Target.Column), Target.Value) > 1 Then
MsgBox "Row Having Same Value"
Application.EnableEvents = False
Target.ClearContents: Target.Select
Application.EnableEvents = True
End If
End If
End If
End Sub
The below code copies cell data (range F1:H19), on clicking, and pastes them to the last row of a different worksheet of the same workbook.
When I click on merged cells nothing happens. Like when cells are empty.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("f1:h19")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Cancel = True
Dim Lastrow As Long
Lastrow = Sheets("sheet1").Cells(Rows.Count, "C").End(xlUp).Row + 1
Target.Copy Sheets("sheet1").Cells(Lastrow, 3)
End If
End Sub
Nothing is happening, because if Target is a merged cell, then Target.Cells.Count is greater than 1.
I would change your logic using Range.MergeCells to determine if a merged cell was clicked:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Me.Range("f1:h19")) Is Nothing Then Exit Sub
If Not Target.MergeCells Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Else
If IsEmpty(Target.Cells(1, 1)) Then Exit Sub
End If
Cancel = True
Dim Lastrow As Long
Lastrow = Sheets("sheet1").Cells(Rows.Count, "C").End(xlUp).Row + 1
Target.Cells(1, 1).Copy Sheets("sheet1").Cells(Lastrow, 3)
End Sub
The code below will add contents of A to B and then clear A across the entire column. How do I duplicate this function to have multiple columns with their own targets inside the same sub? Do I have to write a private sub for each?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim T As Range, r As Range
Set T = Intersect(Target, Range("A:A"))
If T Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In T
With r
.Offset(0, 1).Value = .Offset(0, 1).Value + .Value
.ClearContents
End With
Next r
Application.EnableEvents = True
End Sub
Thank you!
Single column:
Try using Select Case with Target.Column to determine what to do based on column that had event. Adding a GetLastRow function, following helpful comment from #AJD, to ensure only looping populated column range.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Columns.Count <> 1 Then Exit Sub
Select Case Target.Column
Case 1
'col A do something
ClearRange Target
Case 2
'col B do something
ClearRange Target
'Etc
End Select
Application.EnableEvents = True
End Sub
Public Sub ClearRange(ByVal T As Range) '<== This works on the basis Target is a single column
Dim r As Range, loopRange As Range, ws As Worksheet
Set ws = ThisWorkbook.Worksheets(T.Parent.Name)
Set loopRange = ws.Range(ws.Cells(1, T.Column), ws.Cells(GetLastRow(ws, T.Column), T.Column))
If loopRange Is Nothing Then Exit Sub
'Debug.Print loopRange.Address
For Each r In loopRange
With r
.Offset(0, 1).Value = .Offset(0, 1).Value + .Value
.ClearContents
End With
Next r
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
tl;dr;
Multi-column:
You can re-write yours as follows. Though I am not sure what happens with multiple columns. Say, columns A:B, simplest case, were Target, does A get looped transfer and added to B, A gets cleared, B gets looped, added to C and B gets cleared? I wasn't really clear so haven't written anything for the inner part. I simply addressed the title of how to add more targets. Happy to update upon clarification.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("A:A")) Is Nothing Then
End If
If Not Intersect(Target, Range("B:B")) Is Nothing Then
End If
Application.EnableEvents = True
End Sub
I have two VBA functions, but i am unable to call the other from the first function.
Function 1:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim lastRow As Long
With ActiveSheet
lastRow = .Cells(.Rows.count, "A").End(xlUp).Row
Dim I, J As Integer
For I = 1 To lastRow
If Cells(I, "C").Value = "" Then
MsgBox "Please Enter Business Type Value", vbOKOnly
Exit Sub
End If
Next I
End With
End Sub
And the 2nd function:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
Application.EnableEvents = False
If Not Application.Intersect(Target, Me.Columns(3)) Is Nothing Then
ActiveSheet.Unprotect
Select Case Target.Value
Case Is = "CNS"
Target.Offset(0, 4).Locked = True
Case Is = "cns"
Target.Offset(0, 4).Locked = True
Case Is = "APL"
Target.Offset(0, 4).Locked = False
Case Is = "apl"
Target.Offset(0, 4).Locked = False
Case Else
MsgBox "Value not covered by the program", vbInformation + vbOKOnly
End Select
ActiveSheet.Protect
Else
End If
Application.EnableEvents = True
End Sub
please help somebody..
thanks in advance..
In the same module you just call nameoffunction
You can make function public
public sub function
But it's a poor (sometime good) solution. You should structure your code
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
call modul1.function1 ( Target ) ' As Range)
End sub
Private Sub Worksheet_Change(ByVal Target As Range)
call modul1.function1 ( Target ) ' as range
call modul1.function2 ( Target )
end sub
edit ok ugly way
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
....
call Worksheet_change ( Target)
End sub