The purpose of my code is to copy from columns in the same row as the cell 'G4' when cell contents are changed. However, nothing is happening when I change G4's contents.
Private Sub Worksheet_Change3(ByVal Target As Range)
If Target.Address = "$G$4" Then
Range("G4").Select
Selection.Offset(0, -6).Resize(Selection.Rows.Count + 0, _
Selection.Columns.Count + 2).Copy
End If
End Sub
To copy columns A:C on a row when the value in ColG is changed you could try something like this:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Target.Column = 7 Then Target.EntireRow.Range("A1:C1").Copy
End Sub
A Worksheet Change: Copy Columns in the Same Row
Private Sub Worksheet_Change(ByVal Target As Range)
' Reference the source cell.
Dim sCell As Range: Set sCell = Range("G4")
' 'Target' could be multiple cells e.g. if you paste a range. To check
' if one of those cells is the source cell and to attempt to reference it,
' use 'Intersect':
Dim iCell As Range: Set iCell = Intersect(sCell, Target)
' Use the following line to check if 'iCell' is a range (or 'Nothing'):
If Not iCell Is Nothing Then
' Reference columns 'A:C' in the row of the source cell
' by using 'EntireRow' with 'Columns':
Dim irg As Range: Set irg = iCell.EntireRow.Columns("A:C")
' Copy the range.
irg.Copy
' Else 'iCell' is 'Nothing' i.e. 'sCell' is not a cell of 'Target'
End If
End Sub
Related
I have an issue where I use this statement (below) to replace any cell within a specified range to auto default to "$0" if the cell has been emptied or deleted. The problem is that if I select multiple cells and delete or use the click and drag calculate feature to autofill dollar amounts then I throw a "type mismatch" error on the elseif line.
Can someone help me find a workaround to still mass delete or fill a group of cells?
Statement below.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("Editable")) Is Nothing Then
ElseIf Target = "" Then Target = "$0"
End If
Calculate
End Sub
A Worksheet Change: Replace Blank Cells
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim irg As Range: Set irg = Intersect(Target, Range("Editable"))
If irg Is Nothing Then Exit Sub
Dim urg As Range
Dim iCell As Range
For Each iCell In irg.Cells
If Len(CStr(iCell.Value)) = 0 Then
If urg Is Nothing Then
Set urg = iCell
Else
Set urg = Union(urg, iCell)
End If
End If
Next iCell
If urg Is Nothing Then Exit Sub
Application.EnableEvents = False
urg.Value = "$0"
Application.EnableEvents = True
Calculate ' ?
End Sub
I am working on a worksheet that will enter static date and time in an excel worksheet when a value is typed in a target cell. However, the worksheet will be used where values are copied from a downloaded file and pasted to the macro worksheet. When values are typed, the date and time worked as expected but if values are pasted, the VBA code does not work, it has to be typed. How can I make that possible?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("C2:C100")) Is Nothing Then
With Target(1, -1)
.Value = Date
.EntireColumn.AutoFit
End With
End If
End Sub
Something like this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range
'any updates to C2:C100 ?
Set rng = Application.Intersect(Target, Me.Range("C2:C100"))
If Not rng Is Nothing Then
'loop over all updated cells
For Each c In rng.Cells
c.Offset(0, -2).Value = Date
Next c
rng.Offset(0, -2).EntireColumn.AutoFit
End If
End Sub
Add Date Stamp on Cell Change
Pick one.
Easy
Private Sub Worksheet_Change(ByVal Target As Range)
Const cFirst As String = "C2"
Const dCol As String = "A"
Dim rg As Range
Set rg = Range(cFirst).Resize(Rows.Count - Range(cFirst).Row + 1)
Set rg = Intersect(Target, rg)
If Not rg Is Nothing Then
' Since you cannot manually paste a non-contiguous range
' (you can copy one), you can get away with the following line:
rg.EntireRow.Columns(dCol).Value = Date
rg.EntireColumn.AutoFit
End If
End Sub
Hard
Private Sub Worksheet_Change(ByVal Target As Range)
Const cFirst As String = "C2"
Const dCol As String = "A"
' Create a reference to the column range from 'cFirst'
' to the bottom-most cell in the worksheet.
Dim rg As Range: Set rg = Intersect(Target, _
Range(cFirst).Resize(Rows.Count - Range(cFirst).Row + 1))
If rg Is Nothing Then Exit Sub
' If you plan to populate the cells via VBA, then you could write
' non-contiguously to the column range,
' e.g. with 'Range("C3,C5:C7,C10:20").value = 1'.
' Then you could use the following:
Dim dDate As Date: dDate = Date
Dim arg As Range
For Each arg In rg.Areas
arg.EntireRow.Columns(dCol).Value = dDate
Next arg
rg.EntireColumn.AutoFit
End Sub
Tough
Private Sub Worksheet_Change(ByVal Target As Range)
addDateStamp Target, "C2", "A"
End Sub
' This is usually, but not necessarily, located in a standard module.
Sub addDateStamp( _
ByVal TargetRange As Range, _
ByVal FirstCellAddress As String, _
ByVal DateStampColumn As String)
If Not TargetRange Is Nothing Then
Dim rg As Range
With TargetRange.Worksheet.Range(FirstCellAddress)
Set rg = .Resize(.Worksheet.Rows.Count - .Row + 1)
End With
Set rg = Intersect(TargetRange, rg)
If Not rg Is Nothing Then
Dim dDate As Date: dDate = Date
Dim arg As Range
For Each arg In rg.Areas
arg.EntireRow.Columns(DateStampColumn).Value = dDate
Next arg
rg.EntireColumn.AutoFit
End If
End If
End Sub
So I know that one can format cells to be locked and then protect a worksheet to prevent that data being overwritten. But I'm looking to be able to dynamically lock cells within a sheet. From doing some Googling I've tried adapting the below block of code for my needs. The intent is that if column A has a value the rest of the row will be locked so no one can overwrite the rest of the row.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(ActiveSheet.Cells(18, 1), Target) Is Not Nothing Then
If ActiveSheet.Cells(18, 1).Text = "X" Then
ActiveSheet.Range(Cells(18, 2), Cells(18, 20)).Locked = True
Else
ActiveSheet.Range(Cells(18, 2), Cells(18, 20)).Locked = False
End If
End If
End Sub
Any help would be much appreciated, as well as tips for succinctly applying this to every row in the sheet.
UPDATE:
Per BigBen's answer I've revised to the following:
Private Sub Workbook_Open()
Sheets(“Sheet8”).Protect Password:="Secret", UserInterFaceOnly:=True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Intersect(Me.Columns(1), Target)
If rng Is Nothing Then Exit Sub
Dim cell As Range
For Each cell In rng
cell.EntireRow.Locked = (cell.Value = "X")
Next
End Sub
But that still doesn't seem to be working...
You need to change the Intersect to test if Target intersects column A, and not a particular cell:
Note also the Not syntax: If Not Intersect... Is Nothing, instead of If Intersect... Is Not Nothing.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Me.Columns(1), Target) Is Nothing Then
Dim rng as Range
For Each rng in Intersect(Me.Columns(1), Target)
If rng.Value = "X" Then
rng.EntireRow.Locked = True
Else
rng.EntireRow.Locked = False
End If
Next
End If
End Sub
Or perhaps a bit more succinctly:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Intersect(Me.Columns(1), Target)
If rng Is Nothing Then Exit Sub
Dim cell As Range
For Each cell In rng
cell.EntireRow.Locked = (cell.Value = "X")
Next
End Sub
I want to sort an amount of data in Excel. It should toggle between ascending and descending on every click.
I'd found this problem solved in the next thread:
sort ascending/descending vba excel.
But I want to do some changes in the code.
I want to sort using the current column where I clicked (the headers). I don't know if this is possible using just one macro and sending the cell where I call the event.
Here is the code that I'm using:
Worksheet (where I call the Sub):
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Selection.Count = 1 Then
If Not Intersect(Target, Range("A2:C2")) Is Nothing Then
Call sort_table(Target)
End If
End If
End Sub
Sub:
Sub sort_by_letters(Order As Range)
Dim dataRange As Range
Dim fieldOrder As Range
Dim xlSort As XlSortOrder
Dim LastRow As Long
With ActiveSheet
Set LastRow = .Cells(.Rows.Count, Order).End(xlUp).Row
End With
If (Order.Value > Range(Column(Order) & CStr(LastRow))) Then
xlSort = xlAscending
Else
xlSort = xlDescending
End If
Set dataRange = Range("A2:C" & LastRow)
Set campoOrden = Order
dataRange.Sort key1:=fieldOrder, order1:=xlSort, Header:=xlYes
End Sub
Sort on Selection Change
Sheet Module e.g. Sheet1
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Selection.Count = 1 Then
If Not Intersect(Target, Range(strHeaders)) Is Nothing Then
SortTable Target
End If
End If
End Sub
Standard Module e.g. Module1
Public Const strHeaders As String = "A2:C2"
Sub SortTable(Target As Range)
Dim LuCell As Range ' Last Used Cell Range
Dim rngS As Range ' Sort Range
Dim xlSort As XlSortOrder ' Sort Order
' In Target Worksheet
With Target.Worksheet
' Calculate last used cell in Target Column.
Set LuCell = .Cells(.Rows.Count, Target.Column).End(xlUp)
' Check if value in first row below Headers in Target Column is greater
' than value in Last Used Cell Range.
If Target.Offset(1) > LuCell Then
xlSort = xlAscending
Else
xlSort = xlDescending
End If
' In Headers Range
With .Range(strHeaders)
' Calculate Sort Range.
' Create a reference to Sort Range.
Set rngS = .Resize(LuCell.Row - .Row + 1)
End With
End With
' Sort Sort Range.
rngS.Sort Key1:=Target, Order1:=xlSort, Header:=xlYes
End Sub
I'm trying to make a macro that copies the values inside certain cells of sheet1 and pastes then in sheet2.
This is a formula that i wrote inside cell "AI2":
=IFERROR(SUM(1+AH:AH),"0")
and it produces a number that I want to use in the macro as a variable row coordinate.
This is the code i have in my worksheet in order to trigger the macro:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Range("AI2") <> 0 Then
Call macro1
End If
End Sub
And this is the macro:
Sub macro1()
Dim RV As Integer
RV = Sheets("sheet1").Range("AI2").Value
Cells(RR, 33).Select
Range(ActiveCell.Offset(0, -6), ActiveCell.Offset(0, -1)).Select
Selection.Copy
Sheets("sheet2").Select
Range("A1048576").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
If I delete the first 3 lines of code, the macro works, but I have to manually select the cell for the offsets to reference from.
I need to make it so the value of cell "AI2" is used as the first coordinate in this line of code:
Cells(RR, 33).Select
I am very new to any kind of programming, but I want to learn this in order to achieve my goals for this spreadsheet and future ones with similar functions.
I am limiting the scope of your Worksheet_Change to only fire when a change is registered in Column AH since this is the column that will trigger a formula change in Column AI
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 34 Then
If Range("AI2") <> 0 Then
Macro2
End If
End If
End Sub
Sub Macro2()
Dim cs As Worksheet: Set cs = ThisWorkbook.Sheets("Sheet1")
Dim ps As Worksheet: Set ps = ThisWorkbook.Sheets("Sheet2")
Dim xRow As Long, LR As Long
LR = ps.Range("A" & ps.Rows.Count).End(xlUp).Offset(1).Row
xRow = cs.Range("AI2").Value
cs.Range(cs.Cells(xRow, "AB"), cs.Cells(xRow, "AG")).Copy
ps.Range("A" & LR).PasteSpecial xlPasteValues
End Sub
Copy Range to First Empty Cell
Calculate
If you are using a formula in the cell range AI2 you should use the Worksheet Calculate event which will occur everytime the formula is being calculated.
Standard Module
Option Explicit
Public Const strRange As String = "AI2"
Public vntValue As Variant
Sub macro1()
Dim rng As Range ' Target Cell Range
Dim RV As Long ' Row Value
' In Target Worksheet
With ThisWorkbook.Sheets("Sheet2")
' Calculate the first empty (unused) cell in column A (A1 not included).
Set rng = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
End With
' In Source Worksheet
With ThisWorkbook.Worksheets("Sheet1")
' Write the value of Row Cell to Row Value.
RV = .Range(strRange).Value
With .Cells(RV, "AH") ' or 33
' Copy range from "AB" to "AG" in row defined by Row Value in
' Source Worksheet to the range from "A" to "F" in row of Target
' Cell Range in Target Worksheet.
rng.Resize(, 6) = Range(.Offset(0, -6), .Offset(0, -1)).Value
End With
End With
End Sub
Sheet1
Option Explicit
Private Sub Worksheet_Calculate()
If vntValue <> Range(strRange).Value Then
vntValue = Range(strRange).Value
If Range(strRange).Value <> "0" Then macro1
End If
End Sub
ThisWorkbook
Option Explicit
Private Sub Workbook_Open()
vntValue = Worksheets("Sheet1").Range(strRange).Value
End Sub
Change
If you are manually changing the values in the cell range AI2, you have to use the Worksheet Change event.
Standard Module
Option Explicit
Sub macro1()
Dim rng As Range ' Target Cell Range
Dim RV As Long ' Row Value
' In Target Worksheet
With ThisWorkbook.Sheets("Sheet2")
' Calculate the first empty (unused) cell in column A (A1 not included).
Set rng = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
End With
' In Source Worksheet
With ThisWorkbook.Worksheets("Sheet1")
' Write the value of Row Cell to Row Value.
RV = .Range("AI2").Value
' In cell at the intersection of Row Value and column "AH".
With .Cells(RV, "AH") ' or 33
' Copy range from "AB" to "AG" in row defined by Row Value in
' Source Worksheet to the range from "A" to "F" in row of Target
' Cell Range in Target Worksheet.
rng.Resize(, 6) = Range(.Offset(0, -6), .Offset(0, -1)).Value
End With
End With
End Sub
Sheet1
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const cCell As String = "AI2"
If Target = Range(cCell) Then
If Range(cCell).Value <> "0" Then macro1
End If
End Sub
Like in the Calculate version, you might also want to use a public variable (vntValue) to prevent triggering macro1 in case the value in cell range AI2 hasn't actually changed.