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.
Related
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
First let me say that I am freshly new to VBA coding. My spreadsheet has 8 tabs(1 hidden and 1's a chart). Of the other 6 tabs, I would like the code to be able to run on them as well, I just don't know how. I have two sets of code and I am trying to combine them. They are event related codes. I can get them both to run separately but only on a specified sheet. I'm testing them on the "New" tab. The first code sorts the rows after the date is entered into column "H". The other code will cut and paste the entire row into the corresponding tab based on a selection from the drop down list in column "O". I created a call function for both however, only the first code will do anything. Here is what I have so far:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngChng As Range
Set rngChng = Intersect(Target, Range("H:H"))
If rngChng Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
Application.ScreenUpdating = False
Call AutoSort(rngChng)
Set rngChng = Intersect(Target, Range("O:O"))
If rngChng Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
Call CopyNPaste(rngChng)
Application.ScreenUpdating = True
End Sub
Sub AutoSort(rngChng As Range)
Range("A2:O1000").Sort Key1:=Range("H1"), Order1:=xlAscending, Header:=xlNo
End Sub
Sub CopyNPaste(rngChng As Range)
Dim ws As Worksheet
For Each ws In Sheets
If ws.Name <> "New" Then
If ws.Name = Target Then
Target.EntireRow.Copy Sheets(ws.Name).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Target.EntireRow.Delete Shift:=x1Up
End If
End If
Next ws
End Sub
To run the same code from many sheets move the code to a module. Use insert->module on the menu bar, if there are no others it will be named Module1.
In each relevant sheet add the code
Private Sub Worksheet_Change(ByVal Target As Range)
Call Module1.sortOrCopy(Target)
End Sub
Put the sortOrCopy sub in the module. I would suggest using the Target.column
value rather than Intersections to control the program flow.
Put the target.cells.count check once at the start. Pass parameters to your 2 subs.
Sub sortOrCopy(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
Dim ws As Worksheet
Set ws = Target.Parent
If Target.Column = 8 Then ' col H
Call AutoSort(ws)
ElseIf Target.Column = 15 Then ' col O
Call CopyNPaste(Target)
End If
End Sub
For the AutoSort sub the only parameter required is the sheet which will be Target.parent.
You can set the sort range rather than hard coding it using .end(xlUp.row as you have in the other sub.
Sub AutoSort(ws As Worksheet)
Dim iLastRow As Long
' last row of sort range
iLastRow = ws.Range("H" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Range("A2:O" & iLastRow).Sort Key1:=Range("H1"), Order1:=xlAscending, Header:=xlNo
Application.ScreenUpdating = True
End Sub
For the sub CopyNPaste, pass the Target so that the source,row and destination can be determined.
Try to structure the code in simple steps by not doing too much in one line. If the code doesn't work as expected it is easier then to add debug.print or msgBox statements at the various steps. Comment out the If .. End if you don't want user confirmation of the change.
Sub CopyNPaste(Target)
Dim wsCopyTo As Worksheet, iInsertRow As Long, text As String
Set wsCopyTo = Sheets(Target.Value)
' find last row on CopyTo sheet, insert below
iInsertRow = 1 + wsCopyTo.Range("A" & Rows.Count).End(xlUp).Row
text = "Copy line to sheet " & wsCopyTo.Name & " row " & iInsertRow
If MsgBox(text, vbYesNo) = vbYes Then
With Target.EntireRow
.Copy wsCopyTo.Range("A" & iInsertRow)
.Delete Shift:=xlShiftUp
End With
End If
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
I have code that retrieves information from SQL and VFP and populates a dropdown list in every cell in column "A" except A1 - this is a header.
I need to populate the "G" column on the row where the user selects the value from a dropdown in the "A" column.
I believe I need to be in Private Sub Worksheet_SelectionChange(ByVal Target As Range) which is in the sheet object.
Below is something similar to what I want to do.
If cell "a2".valuechanged then
Set "g2" = "8000"
End if
If cell "a3".valueChanged then
Set "g3" = "8000"
End if
The code above doesn't work, but I think it is easy to understand. I want to make this dynamic, so I don't have too many lines of code.
I have already explained about events and other things that you need to take care when working with Worksheet_Change HERE
You need to use Intersect with Worksheet_Change to check which cell the user made changes to.
Is this what you are trying?
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
'~~> Check if user has selected more than one cell
If Target.Cells.CountLarge > 1 Then Exit Sub
Application.EnableEvents = False
'~~> Check if the user made any changes in Col A
If Not Intersect(Target, Columns(1)) Is Nothing Then
'~~> Ensure it is not in row 1
If Target.Row > 1 Then
'~~> Write to relevant cell in Col G
Range("G" & Target.Row).Value = 8000
End If
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Try this
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row > 1 And Target.Column <> 7 Then
Cells(Target.Row, "G").Value = 8000
End If
End Sub
If you only need it to fire on column A then
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row > 1 And Target.Column = 1 Then
Cells(Target.Row, "G").Value = 8000
End If
End Sub
can you not put an if statement in column G , as in
If (A1<>"", 8000,0)
Other wise something like this will get you going:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Column = 1 Then
If Target.Value2 <> "" Then
Target.Offset(0, 6) = "8000"
Else
Target.Offset(0, 6) = ""
End If
End If
On Error GoTo 0
End Sub
Thanks
Ross
I had a similar problem. I used Siddharth Rout's code. My modifications allow a user to paste a range of cells in column a (ex. A3:A6) and have multiple cells modified (ex. H3:H6).
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
'~~> Check if user has selected more than one cell
If Target.Cells.CountLarge < 1 Then Exit Sub
If Target.Cells.CountLarge > 500 Then Exit Sub
Debug.Print CStr(Target.Cells.CountLarge)
Application.EnableEvents = False
Dim the_row As Range
Dim the_range As Range
Set the_range = Target
'~~> Check if the user made any changes in Col A
If Not Intersect(the_range, Columns(1)) Is Nothing Then
For Each the_row In the_range.Rows
'~~> Ensure it is not in row 2
If the_row.Row > 2 Then
'~~> Write to relevant cell in Col H
Range("H" & the_row.Row).Value = Now
End If
Next
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
I have a code in Worksheet_Change
If a column 9 is updated then the column 8 will be automatically populated by multiplying with col 9 and col 11.
But when the user pastes the values in the column, the change event does not work correctly. Only the first cell in the Col 8 gets updated.
How can I overcome from this?
Try this
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
Application.EnableEvents = False
If Target.Columns.Count > 1 Then GoTo LetsContinue
If Not Intersect(Target, Columns(9)) Is Nothing Then
Dim aCell As Range
For Each aCell In Target
aCell.Offset(, -1).Value = aCell.Value * aCell.Offset(, 2)
Next
End If
LetsContinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub