I'm relatively new to VBA. I have this sub procedure CutePaste, that I call in worksheet_change(ByVal Target As Range), that executes whenever the value in column "F" is changed. My goal is to copy the entire row of the cell changed and paste it into another sheet ("Cast Worked"). My code right now only copies the updated cell and paste that to the new sheet. Please advise how I can copy the entire row of the updated cell.
Sub CutPaste()
If Not Intersect(myTarget, Range("F:F")) Is Nothing Then
ActiveCell.Activate
a = Sheets("Cast Worked").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Cast Worked").Range("A" & a).Value = ActiveCell.Value
ActiveCell.Offset(1, 0).Select
End If
End Sub
You are close. You can use the Range.Copy method to do this. Furthermore you need to pass the target from the worksheet_change event to your subroutine.
Sub worksheet_change(ByVal Target As Range)
'Pass target range to subroutine
CutPaste(Target)
End Sub
Sub CutPaste(myTarget As Range)
If Not Intersect(myTarget, Range("F:F")) Is Nothing Then
a = Sheets("Cast Worked").Cells(Rows.Count, "A").End(xlUp).Row + 1
Target.EntireRow.Copy Destination:=Sheets("Cast Worked").Range("A" & a)
Target.Offset(1, 0).Select
End If
End Sub
I removed ActiveCell.Activate since setting the active cell to active is superfluous.
Related
I am trying to write macros code where, when the value of drop down under a column in table with header "Status", changes to "completed", then Sub Completedarc should run automatically. I am able to write a code when action status is changed to completed in one column but not the entire column in a table. Also,Sub Completedarc() is only cut pasting values in another sheet but not deleting the overcall row and it is left blank
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = Range "Open_Project_Details[[#Headers],[Status]]") Then
Select Case Target.Value
Case "Completed"
Call Completedarc
End Select
End If
End Sub
Sub Completedarc()
Rows(ActiveCell.Row).EntireRow.Cut
Sheets("Completed Archive").Select
Range("Completed_Archive[[#Headers],[Stack Rank]]").Select
Selection.End(xlDown).Select
If ActiveCell = "" Then
ActiveSheet.Paste
Else
ActiveCell.Offset(1).Activate
ActiveSheet.Paste
End If
End Sub
If I well understood your question, this changed event will do what you need:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Target.ListObject Is Nothing Then
If Intersect(Target.ListObject.HeaderRowRange, _
Target.EntireColumn).value = "Status" Then
If Target.value = "Completed" Then
Call Completedarc(Target) 'added an argument...
End If
End If
End If
End Sub
About the Completedarc sub, I do not understand what is to be done. Does your "Open_Project_Details" table starts from column A:A and you want copying the table Target row in the first empty cell of the "Completed_Archive" table/column "Stack Rank"? Do you want to copy it inserting a new row after the table last one?
If this last one supposition is what you want, please use the next code:
Sub Completedarc(Target As Range)
Dim TRows As Long, shCA As Worksheet
Set shCA = Worksheets("Completed Archive")
TRows = shCA.Range("Completed_Archive[Stack Rank]").cells.count
If TRows = 1 Then TRows = TRows + 1
Intersect(Target.ListObject.DataBodyRange, Target.EntireRow).Copy _
shCA.Range("Completed_Archive[Stack Rank]").cells(TRows)
'the next code line only selects the row to be deleted. If it selects what you need
'you would only replace `Select` with `Delete` and the code will delete such rows
Target.EntireRow.Select 'Delete
End Sub
Cut/Paste Table Row on Cell Change
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
completeArchive Target
End Sub
Sub completeArchive(ByVal Target As Range)
If Target.Cells.CountLarge = 1 Then
Dim ws As Worksheet: Set ws = Target.Worksheet
Dim rg As Range
Set rg = Intersect(Target, ws.Range("Open_Project_Details[Status]"))
If Not rg Is Nothing Then
If rg.Value = "Completed" Then
Set rg = Intersect(ws.Rows(rg.Row), _
ws.Range("Open_Project_Details"))
With ws.Parent.Worksheets("Completed Archive")
With .Range("Completed_Archive[Stack Rank]")
rg.Copy .Cells(.Rows.Count + 1)
rg.Delete
End With
End With
End If
End If
End If
End Sub
Whenever I change a value (choose some value from data validation list) in column G, it should clear the cell in the next column H.
So when I choose value in G4, value in H4 will be deleted. When I choose value in G5, tha same would happen with H5.
I tried this, but not working:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 7 Then
For i = 4 To 154 Step 1
If Target.Address = "$G$i" Then
Range("Hi").Select
Selection.ClearContents
End If
Next i
End If
End Sub
No need of iteration for such a task. Since, the cell value is changed by selecting from a drop down validation list, multiple changes are not possible. For such a case, the code simple exists:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 7 Then
If Target.cells.count > 1 Then Exit Sub
Target.Offset(0, 1).ClearContents
End If
End Sub
This can be done like this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim oCell As Range
For Each oCell In Target.Cells ' You can change many cells at once (i.e. copy-paste or select-delete)
If oCell.Column = 7 Then ' Is it cell in G:G or any other?
If oCell.Text <> vbNullString Then ' Has cell any value?
oCell.Offset(0, 1).ClearContents ' Clear cell in the next column in this row
End If
End If
Next oCell
End Sub
I'm very new to using macros in Excel, so I hope this question isn't too silly.
I'm creating a worksheet to track sales. I've got a list of drinks in one column and I wanted to assign a macro to the cells so that when you click on them, the text in their cells is copied to another column.
I know you can record macros to copy-and-paste values, but I'm not sure how to make it copy the text in the next empty cell in the column, and not just in the first cell.
So in summary, these are my tables. I want to be able to click a cell in the Drinks column, and have the string appear at the bottom of the list column (so after 'Cuba Libre')
Thanks!
EDIT_1:
Ok, so here's my code so far:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$C$2" Then
Range("C2").Select
Selection.Copy
Range("A2").Select
ActiveSheet.Paste
End If
End Sub
^I've repeated this code for each of the relevant cells in column C (C2:C5).
Like I said, I've only gotten to the point of being able to copy paste the values from the Drinks column into the List column, I am lost as to how to paste the value into the next empty cell.
You need to expand your check on Target to include the whole Drinks range. Then determine the next available cell in List
Something like (hard coded for List in Column A and Drinks in Column C)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rDrinks As Range
' single cell has been selected
If Target.Cells.Count = 1 Then
' Get ref to Drinks range
Set rDrinks = Me.Range(Me.Cells(2, 3), Me.Cells(Me.Rows.Count, 3).End(xlUp))
' Is selected cell in drinks range?
If Not Application.Intersect(Target, rDrinks) Is Nothing Then
' add to list
Me.Cells(Me.Rows.Count, 1).End(xlUp).Offset(1, 0).Value2 = Target.Value2
End If
End If
End Sub
UPDATE
So I've managed to figure out how to get the macro to paste the cell value at the bottom of the list!
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LastRow As String
If Target.Address = "$C$2" Then
Range("C2").Select
Selection.Copy
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & LastRow).Activate
ActiveSheet.Paste
Application.CutCopyMode = False
End If
End Sub
However, I've got a quality-of-life question. Is there any way to edit the code so that it applies to all the cells in the range C2:C10? Because as it stands, I would have to repeat the code for each cell replacing lines 3 & 4 for all the cells in range.
If Target.Address = "$C$2" Then
Range("C2").Select
If you actually turn List and Drinks into tables (with those names), you could use the following code
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Integer
Dim row As Integer
' Check user has clicked on a drink
If Not Intersect(Target, [Drinks]) Is Nothing And Target.Cells.Count = 1 Then
' Find first blank row in List
For i = [List].Rows.Count To 1 Step -1
If [List].Cells(i, 1) = "" Then
row = i
End If
Next
' If no blank row, add a new row
If row = 0 Then
ListObjects("List").ListRows.Add
row = [List].Rows.Count
End If
[List].Cells(row, 1) = Target
End If
End Sub
I need to highlight and entire row if a cell string contains the word "risk". But I need to make it using vba since the person using it will write on it after using the macro.
I have something like:
The reason will be written afterwards and I need to highlight the row if someone writes the word risk anywhere in this column. Anything can be written there.
I use this to highlite a row when I want a full match:
lastReg= Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = Range("A1:J" & lastReg)
Rng.FormatConditions.Add Type:=xlExpression, Formula1:="=$J1=""Plat"""
...
so I tried:
Rng.FormatConditions.Add Type:=xlExpression, Formula1:="=FIND(""risk"",$J1)>0"
But it doesn't work.
Edit: it gives me an execution error so the code itself doesn't run.
Edit2: Someone else uses this macro, and he can't do it by himself so I wanted the code to do it for him.
Also, the code is stored in the personal.xlsb because he runs the code in a different worksheet everyday, so I can't pre config the formatConditions for the worksheet.
I would use a worksheet change event. place this sub in your worksheet. Whenever any cell in column 5 changes and the value is "risk", it will color the row.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
Set Rng = Columns(5)
If Not Intersect(Rng, Target) Is Nothing And Target.Value = "risk" Then
Target.Offset(, -4).Resize(, 5).Interior.Color = vbYellow
End If
End Sub
Try:
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim cell As Range
If Not Intersect(Target, Sh.UsedRange) Is Nothing Then
For Each cell In Target.Cells
With cell
If UCase(.Value) = "RISK" Then
.Font.Color = vbRed
Else
.Font.Color = vbBlack
End If
End With
Next cell
End If
End Sub
What I am needing: A macro to be triggered, let's call the macro "MacroRuns", whenever cell C3 returns a different value than it currently has, based on its FORMULA, NOT based on manually typing a different value.
I have spent all day reading through and attempting every "solution" on the first two pages of my google search on this topic. So far, nothing seems to work for me. Please help!!! I would very much appreciate it!
Example:
I have now tried this but it corrupts my file after it works a few times.
Private Sub Worksheet_Calculate()
If Range("E3") <> Range("C3").Value Then
Range("E3") = Range("B3").Value
MsgBox "Successful"
End If
End Sub
Module1, Sheet1 (Calculate), ThisWorkbook (Open)
Highlights
When the workbook opens, the value from C3 is read into the public
variable TargetValue via TargetStart.
When the value in C3 is being calculated, TargetCalc is activated
via the calculate event.If the current value in C3 is different than TargetValue, MacroRuns is triggered and TargetValue is updated with the value in C3.
The Code
Module1
Option Explicit
Public TargetValue As Variant
Private Const cTarget As String = "C3"
Sub TargetCalc(ws as Worksheet)
If ws.Range(cTarget) <> TargetValue Then
MacroRuns
TargetValue = ws.Range(cTarget).Value
End If
End Sub
Sub TargetStart()
TargetValue = Sheet1.Range(cTarget).Value
End Sub
Sub MacroRuns()
MsgBox "MacroRuns"
End Sub
ThisWorkbook
Option Explicit
Private Sub Workbook_Open()
TargetStart
End Sub
Sheet1
Option Explicit
Private Sub Worksheet_Calculate()
TargetCalc Me
End Sub
Right. I have a nugget to add in here, something that completely frustrated me upon trying Ferdinando's code (which by itself is very neat, thank you, Ferdinando!!)
The main point is - if you are going to be using anything beyond just a messagebox (MsgBox "Cell has changed.") you need to add the following lines above AND below this line(otherwise the Excel will simply crash constantly due to endlessly trying to do the same). Don't ask me why this is, but I finally-finally solved my problem with this. So here are the lines:
If Value1 <> Value2 Then
(ADD THIS:) Application.EnableEvents = False
MsgBox "Cell has changed."
(I call a macro running a query from MySQL instead of MsgBox)
(AND ADD THIS:) Application.EnableEvents = True
Hope this helps anyone in the situation I was in!!
If i understood your question you can try this code:
1)Right-click the Sheet tab and then click View Code
copy this code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Value1 As Variant
Static Value2 As Variant
Value1 = Range("C3").value
If Value1 <> Value2 Then
MsgBox "Cell has changed."
End If
Value2 = Range("C3").value
End Sub
i tried this one:
in cell C3 i have wrote =SUM(A1:B1)
when i try to change value in this cells also C3 change and i get the msgBox
Hope this helps
EDIT the code to answer # MD Ismail Hosen
if i understood your problem you can try this example code:
Private Sub Worksheet_Change(ByVal Target As Range)
'in this code i have used two range on the same row, but you can change as
'you want.
'In my case, the range that i check is Range("A1:C1") and the RANGE that i 'save old value is
'RANGE("F1:H1") F1 is the sixth column.
Dim counter As Byte
Dim sizeRange As Byte
sizeRange = 3 ' my size range
For counter = 1 To sizeRange
'on the left i check Range("A1:C1").On the right i check The Range("F1:H1")
If Cells(1, counter) <> Cells(1, counter + 5) Then 'counter start from 1
MsgBox "Range Changed"
Range("A1:C1").Copy Destination:=Range("F1:H1") ' use other code to copy the range
Exit For
End If
Next counter
End Sub
If you have a formula in your range ("A1:C1") you have to use this code to copy the new range value A1:C1 in F1:H1 else you get the error(loop the macro).
'TO use this code if you have formula in the cells.
Range("A1:C1").Select
Selection.Copy
Range("F1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Hope this helps.