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
Related
I need a simple code which will copy contents of adjacent left cell to double clicked cell. This is to help me in making entries as in attached image.
If I click c2 it should copy 3 from b2 and paste it in c2, and it should do it for c2: c100
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws1 As Worksheet: Set ws1 = wb.Worksheets("sheet1")
With ws1
If Not Intersect(Target, Range("b2:b100")) Is Nothing Then
Cancel = True
If Application.CountIf(Sheets(ws1).Range("b2:b100"), Target.Value) = 0 Then
Cells(Target.Row, 3).Value = Target.Value
End If
End If
End With
End Sub
You can do something like this - note in the worksheet code module, you can use Me to refer to the worksheet.
Technically you don't need to qualify the Range(), since in a worksheet module it defaults to that sheet, but it's good practice to always qualify where you can.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Me.Range("C2:C100")) Is Nothing Then
Cancel = True
with Target.Offset(0, -1)
If Len(.Value) > 0 Then Target.Value = .Value
End With
End If
End Sub
This is a simple code
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Cells.CountLarge > 1 Then Exit Sub
If Not Intersect(Target, Range("C2:C100")) Is Nothing Then
Cancel = True
Target.Value = Target.Offset(, -1).Value
End If
End Sub
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
I have created a simple Excel Macro which is triggered when a user clicks on a cell in a worksheet (worksheet1). Basically the macro takes the value of the cell which was clicked on and selects a target cell in a separate worksheet (worksheet2) that has the same value.
The problem is that about 20% of the time after being directed to worksheet2, the target cell is highlighted but is just out of view, i have to scroll down a couple of rows to see it. I want to be able to ensure that the target cell is always in view after the user is directed to it, but I am not sure how this can be achieved.
This is in Excel 2016.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If ActiveCell.Column = 1 Then
If Target.Cells.Count = 1 Then
Application.ScreenUpdating = False
Dim c As Range
Dim ans As String
Dim Lastrow As Long
ans = ActiveCell.Value
Lastrow = Sheets("worksheet2").Cells(Rows.Count, "A").End(xlUp).Row
For Each c In Sheets("worksheet2").Range("A2:A" & Lastrow)
If c.Value = ans Then Application.Goto Reference:=Sheets("worksheet2").Range(c.Address): Exit Sub
Next
End If
End If
Exit Sub
End Sub
You can use find to find the selected item in sheet2 then just select the sheet and the found cell
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim s As Range
If Target.Column = 1 Then
Set s = Worksheets("Sheet2").Range("B:B").Find(what:=Target, lookat:=xlWhole)
If Not s Is Nothing Then
Worksheets("Sheet2").Activate
s.Select
Else: MsgBox Target.Value & " is not found in sheet 2"
End If
End If
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 Worksheet 1, with columns A to D.
I would like to create a button executing row to be copied to Worksheet 2, as soon as cell C in Worksheet 1 is populated.
I have no experience in Excel at all, so far I found and altered this macro code for my needs:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count = 1 Then
Target.EntireRow.Copy _
Destination:=Sheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
End Sub
But when I try to create a button to execute this macro, it would never work. Could anyone help me solve this, please.
Is this what you are trying? Read more about Worksheet_Change HERE
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim lRow As Long
On Error GoTo Whoa
Application.EnableEvents = False
If Target.Cells.CountLarge > 1 Then Exit Sub
Set ws = ThisWorkbook.Sheets("Sheet2")
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row + 1
If Not Intersect(Target, Columns(3)) Is Nothing Then _
Target.EntireRow.Copy Destination:=ws.Rows(lRow)
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
EDIT:
If the code still doesn't work then from the VBA Editor, press CTRL + G to bring up the immediate window and type this
Application.EnableEvents = True
and press ENTER key and now the code should work.