automatic static date and time when a value was copied from another worksheet and pasted to a sheet with macro - excel

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

Related

How can I use Target.Address with offset

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

Get row number of first empty cell in column and store that value in other cell

I want to find row number of first empty cell in column and store that row number in Cell Z1.
I tried with Following macro code but it goes into loop forever.
As soon as it tries to set the value in Cell Z1 it again goes into worksheet_change event again and then again in for loop.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = ActiveSheet
For Each cell In ws.Columns(3).Cells
If IsEmpty(cell) = True Then Range("$Z$1").Value = cell.Row: Exit For
Next cell
End Sub
Please help to resolve this.
Thanks
Maybe this code is of any help
Option Explicit
Function firstEmptyCell(col As Long, Optional ws As Worksheet) As Range
If ws Is Nothing Then
Set ws = ActiveSheet
End If
Dim rg As Range
Set rg = ws.Cells(1, col)
If Len(rg.Value) = 0 Then
Set rg = rg.Offset
Else
If Len(rg.Offset(1).Value) = 0 Then
Set rg = rg.Offset(1)
Else
Set rg = rg.End(xlDown)
Set rg = rg.Offset(1)
End If
End If
Set firstEmptyCell = rg
End Function
And the Event code is
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo EH
If Target.Column <> 12 Then
Exit Sub
End If
Application.EnableEvents = False
Range("Z1").Value = firstEmptyCell(12).Row
EH:
Application.EnableEvents = True
End Sub
Update: Based on the comments regarding the pitfalls of the change event one could change firstEmptyCell slightly and use a UDF only
Function firstEmptyCellA(col As Long, Optional ws As Worksheet) As Long
On Error GoTo EH
If ws Is Nothing Then
Set ws = ActiveSheet
End If
Application.Volatile
Dim rg As Range
Set rg = ws.Cells(1, col)
If Len(rg.Value) = 0 Then
Set rg = rg.Offset
Else
If Len(rg.Offset(1).Value) = 0 Then
Set rg = rg.Offset(1)
Else
Set rg = rg.End(xlDown)
Set rg = rg.Offset(1)
End If
End If
firstEmptyCellA = rg.Row
Exit Function
EH:
firstEmptyCellA = 0
End Function
Tricky Enable Events
This is triggered only when a cell in the 12th column (L) is changed, otherwise there is no need for it. If you have formulas there, then this will not work and you'll have to use the Worksheet_Calculate event.
Row of First Empty Cell in Column
Option Explicit
' Row of First Empty Cell in Column
Private Sub Worksheet_Change(ByVal Target As Range)
Const TargetCell As String = "Z1"
Const TargetColumn As Variant = 12 ' (or "L")
Dim rng As Range
If Intersect(Columns(TargetColumn), Target) Is Nothing Then Exit Sub
Application.EnableEvents = False
Set rng = Columns(TargetColumn).Find(What:="", _
After:=Cells(Rows.Count, TargetColumn), LookIn:=xlValues)
If rng Is Nothing Then
Range(TargetCell).Value = 0 ' Full column. No empty cells.
Else
Range(TargetCell).Value = rng.Row
End If
Application.EnableEvents = True
End Sub
Row of First Empty Cell After Last Non-Empty Cell in Column
Option Explicit
' Row of First Empty Cell After Last Non-Empty Cell in Column
Private Sub Worksheet_Change(ByVal Target As Range)
Const TargetCell As String = "Z1"
Const TargetColumn As Variant = 12 ' (or "L")
Dim rng As Range
If Intersect(Columns(TargetColumn), Target) Is Nothing Then Exit Sub
Application.EnableEvents = False
Set rng = Columns(TargetColumn).Find(What:="*", LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
If rng Is Nothing Then ' Empty column. No non-empty cells.
Range(TargetCell).Value = 1
Else
If rng.Row = Rows.Count Then ' Last (bottom-most) cell is not empty.
Range(TargetCell).Value = 0
Else
Range(TargetCell) = rng.Offset(1).Row
End If
End If
Application.EnableEvents = True
End Sub
Dont need a loop. Paste this in a module not in a worksheet event unless you want it for every worksheet change.
Sub Macro1()
ActiveSheet.Range("Z1") = ActiveSheet.Columns(3).SpecialCells(xlCellTypeBlanks)(1).Row
End Sub
if you want it after every change then put it in a worksheet as. This code will not run everytime. It will check if Z1 is empty then enter the valu. Then if Z1 is not empty it will check if the target cell is in column C
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
Set Rng = ActiveSheet.Columns(3)
If IsEmpty(Range("Z1")) Then
Range("Z1") = Rng.SpecialCells(xlCellTypeBlanks)(1).Row
Else
If Not Intersect(Range("C1:C" & Range("Z1").Value), Target) Is Nothing Then
Range("Z1") = Rng.SpecialCells(xlCellTypeBlanks)(1).Row
End If
End If
End Sub

Sort ascending/descending in Excel using VBA 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

VBA, If active cell in range does not equal a String call Macro

I am very new to the World of VBA. I am attempting to add to an existing Private Sub(Change). I am trying to "fire" the Macro "DelRCE" When the Active Cell in Range("K2:K700") Does Not equal the word "Down".
The code below is not working:
Dim txt As String
Dim rng As Range
Dim vec As String
txt = ActiveCell.Value
rng = ("K2:K700")
vec = "Down"
If r_ng.txt <> vec Then
Call Macro
End If
I assume you are looking for something like this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim key As String
Dim rng As Range
'Set the word you want to search for. Take capital letters into account
key = "down"
'Set worksheet to the first sheet in your workbook
Set ws = ThisWorkbook.Sheets(1)
'Change this to the range you want to search
Set rng = ws.Range("A1:A100")
'Check if the target is in the range
If Not Intersect(Target, rng) Is Nothing Then
If Target.Value <> key Then
'Change this to you function call
MsgBox "The target is inside the range and the value is different from '" & key & "'"
End If
End If
End Sub
Put the cursor inside the test_Change sub and hit PF5 to run it.
private Sub Change()
Dim txt As String
Dim rng As Range
Dim vec As String
txt = ActiveCell.Value
rng = ("K2:K700")
vec = "Down"
If r_ng.txt <> vec Then
Call DelRCE ' or "Run DelRCE" if it is a function
End If
End Sub
Private Sub test_Change()
call Change
End Sub
Add the code below to the relevent Worksheet module, under the Worksheet_Change event:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim vec As String
vec = "Down"
If Not Intersect(Target, Range("K2:K700")) Is Nothing Then ' check that modifed cell is inside the Range("K2:K700")
If Target.Count > 1 Then Exit Sub ' Optional : if more than 1 cell selected exut the sub
If Not Target.Value Like vec Then ' Also possible to use: If Target.Value <> vec
Call Macro
End If
End If
End Sub

worksheet change event only works when region selected - how to adjust to automatic update

the combination of this sub in a module
Sub hithere3()
Dim Rng As Range
Dim Unique As Boolean
For Each Rng In Worksheets("Sheet8").Range("FS3:FS30") 'for each cell in your B1 to B30 range, sheet1
Unique = True 'we'll assume it's unique
Lastunique = Worksheets("TRADES").Range("C:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For i = 3 To Lastunique 'for each cell in the unique ID cache
If Rng.Value = Worksheets("TRADES").Cells(i, 3).Value Then 'we check if it is equal
Unique = False 'if yes, it is not unique
End If
Next
If Unique Then Worksheets("TRADES").Cells(Lastunique + 1, 3) = Rng 'adds if it is unique
Next
End Sub
with the loop check in a worksheet change events
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("FS3:FS33")) Is Nothing Then
'Do nothing '
Else
Call hithere3
End If
End Sub
works except it only updates when I select one of the cells in FS3:FS33
Can anyone suggest how this can be overcome?
maybe with a workchange change range selection type from below?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Dn As Range, n As Long
Dim RngB As Range, RngC As Range
If Target.Column = 2 And Target.Count = 1 And Target.Row > 1 Then
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
Set RngB = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
Set RngC = Range(Range("C2"), Range("C" & Rows.Count).End(xlUp))
ray = Array(RngB, RngC)
For n = 0 To 1
For Each Dn In ray(n)
If Not Dn.Address(0, 0) = "C1" And Not Dn.Value = "" Then
.Item(Dn.Value) = Empty
End If
Next Dn
Next n
Range("C2").Resize(.Count) = Application.Transpose(.Keys)
End With
End If
Use either the worksheet Calculate event or the worksheet Change event:
use Calculate if the range contains formulas
use Change if the cells in the range are changed manually
If Intersect(Target, Range("FS3:FS33")) Is Nothing is the culprit. You must change Range("FS3:FS33") to whatever range you want to affect this change.
Private Sub Worksheet_Change(ByVal Target As Range) '<<delete the "Selection" from the name of event
If Intersect(Target, Range("FS3:FS33")) Is Nothing Then
'Do nothing '
Else
Call hithere3
End If
End Sub
Finally figured it out, the following code works :
Private Sub Worksheet_calculate()
If Range("FS3:FS33") Is Nothing Then
'Do nothing'
Else
Call hithere3
End If
End Sub

Resources