What´s the best way to log each action executed in VBA? Is there some built-in Windows object that already does this that I can use?
(I'm not referring to user actions)
Thanks
This will log actions typed into cells. Right-click your sheet and paste the code into the window that opens..
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Target, Range("$A$1:$b$400")) Is Nothing Then
Application.EnableEvents = False
Application.ScreenUpdating = False
With Worksheets("Sheet2")
.Select
.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Select
ActiveCell.Value = Target.Address
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Target.Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Now()
ActiveCell.NumberFormat = "mm/dd/yy"
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = InputBox("You've made a change to the Rates tab. Please enter your name here for historical purposes.")
Application.EnableEvents = True
Application.ScreenUpdating = True
End With
End If
End Sub
Related
I am wondering if it is possible to call a private Sub worksheet_Change(ByVal Target As Range) type of sub from another public sub? I know that you can't really 'call' the sub but Run it, however my attempts at running the sub doesn't seem to work. This is what I have tried:
Sub AccessTransfer()
Range("A1:F1").Select
Selection.Copy
Sheets("Sheet2").Select
ActiveSheet.Paste
ActiveCell.Offset(0, 6).Value = "Oven"
Range("A65536").End(xlUp).Offset(1, 0).Select
Run.Application "Private Sub Worksheet_Change(ByVal Target As Range)"
Sheets("Sheet1").Select
Application.CutCopyMode = False
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Application.CountIf(Range("A:A"), Target) > 1 Then
MsgBox "Duplicate Entry", vbCritical, "Remove Data"
Target.Value = ""
End If
Range("A65536").End(xlUp).Offset(1, 0).Select
End Sub
Any help or suggestions on how to fix my problem would be most appreciated.
With Sheets("Sheet2").Range("A65536").End(xlUp).Offset(1, 0)
.Value = .Value
End With
will trigger the Event, but the Paste should already have done that...
EDIT: As commenters have pointed out, there are other issues with your code: this should be something like what you want to do -
Sub AccessTransfer()
Dim shtSrc As Worksheet, shtDest As Worksheet
Dim v, c As Range
Set shtSrc = ActiveSheet
Set shtDest = ThisWorkbook.Sheets("Sheet2")
v = shtSrc.Range("A1").Value 'value to check...
If Application.CountIf(shtDest.Range("A:A"), v) > 0 Then
MsgBox "Value '" & v & "' already exists!", vbCritical, "Can't Transfer!"
Else
'OK to copy over...
Set c = shtDest.Range("A65536").End(xlUp).Offset(1, 0)
shtSrc.Range("A1:F1").Copy c
c.Offset(0, 6).Value = "oven"
End If
Application.CutCopyMode = False
End Sub
There are a couple of things wrong with your code.
You may be making a change (e.g. Target.Value = "") in the Worksheet_Change which will trigger another event.
You haven't isolated Target to column A and have not dealt with more than a single cell being Target.
Module1 code sheet:
Sub AccessTransfer()
With Worksheets("Sheet2")
Worksheets("Sheet1").Range("A1:F1").Copy _
Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
'Sheet2's Worksheet_Change has been triggered right here
'check if the action has been reversed
If Not IsEmpty(.Cells(.Rows.Count, "A").End(xlUp)) Then
'turn off events for the Oven value write
Application.EnableEvents = False
.Cells(.Rows.Count, "A").End(xlUp).Offset(0, 6) = "Oven"
'turn events back on
Application.EnableEvents = True
End If
End With
End Sub
Sheet2 code sheet:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A")) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
Dim c As Long, rngs As Range
Set rngs = Intersect(Target, Range("A:A"))
For c = rngs.Count To 1 Step -1
If Application.CountIf(Columns("A"), rngs(c)) > 1 Then
MsgBox "Duplicate Entry in " & rngs(c).Address(0, 0), _
vbCritical, "Remove Data"
rngs(c).EntireRow.Delete
End If
Next c
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
Please suggest a vb code, that if the text box is left blank,and during TAB/Enter, the Error message box appears for each text box.
Private Sub CommandButton1_Click()
Sheets("Attendance").Select
Range("a1").Select
Do
If IsEmpty(ActiveCell) = False Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell) = True
ActiveCell.Value = Me.d.Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Me.N.Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Me.Salary.Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Me.Remarks.Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Me.IT.Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Me.Outtime.Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Me.Lunch.Value
ActiveCell.Offset(0, 3).Select
ActiveCell.Value = Me.Advance.Value
ActiveCell.Offset(0, 2).Select
ActiveCell.Value = Me.Paid.Value
End Sub
Please see below sub carefully and try to do to your user form.
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Me.TextBox1 = "" Then
MsgBox "You must enter value!"
Cancel = True
Me.TextBox1.SetFocus
End If
End Sub
I'm trying to create a userform in VBA that will search a list in another sheet and display all matching results, is it also possible to have that data displayed by default to then be narrowed down by the search box value?
There are three columns in the list it will search, but if it finds a match, ideally it would display the data from the first and third, the middle column is irrelevant, but needs to stay for other code.
Then you might need to select one of the results to display it in a specific folder in the workbook (column one result in one cell, column two in the cell next to it).
I'm completely new to userforms so a task like this is quite daunting, I'm not even certain how to activate the form from the sheet.
Any feedback is appreciated, I'll comment any useful code I find online.
Accomplished most of what I was after with the following:
Private Sub SearchButton_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
On Error GoTo ErrorHandler
Workbooks("Form1.xlsm").Worksheets("Employees").Visible = True
ActiveWorkbook.Sheets("Employees").Activate
Employee = EmployeeName.Value
lastrow = Range("A" & Rows.Count).End(xlUp).Row
ActiveSheet.Range("$A$2:$C$" & lastrow).AutoFilter Field:=1, Criteria1:= _
"=*" & Employee & "*", Operator:=xlAnd
Workbooks("Form1.xlsm").Worksheets("Temp").Visible = xlSheetVisible
Workbooks("Form1.xlsm").Worksheets("Temp").Range("A1:AFD1000000").ClearContents
'validation to stop the form breaking if a nane is searched that doesnt exist
Range("A1000000").Select
Selection.End(xlUp).Select
If ActiveCell.Value = "KeyID" Then GoTo validationend
'Take the data that has been filtered by employee name and store it in a temp worksheet
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Workbooks("Form1.xlsm").Worksheets("Temp").Activate
Range("A1").Select
ActiveSheet.Paste
'Delete any data that is irrelevant at this stage
Range("D:D").Delete Shift:=xlToLeft
Range("E:E").Delete Shift:=xlToLeft
Range("G:AZ").Delete Shift:=xlToLeft
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Dim rngName As Range
Dim ws As Worksheet
Dim i As Integer
Set ws = Worksheets("Temp")
For i = 1 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row Step 1
If ws.Cells(i, 1).Value <> vbNullString Then Me.ListBox.AddItem ws.Cells(i, 1).Value
Next i
validationend:
Workbooks("Form1.xlsm").Worksheets("Form").Activate
'Workbooks("Form1.xlsm").Worksheets("Temp").Visible = xlSheetVeryHidden
'Workbooks("Form1.xlsm").Worksheets("Employees").Visible = xlSheetVeryHidden
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
ErrorHandler:
MsgBox ("Error: Name not found. Please check your spelling and try again.")
Workbooks("Form1.xlsm").Worksheets("Form").Activate
'Workbooks("Form1.xlsm").Worksheets("Temp").Visible = xlSheetVeryHidden
'Workbooks("Form1.xlsm").Worksheets("Employees").Visible = xlSheetVeryHidden
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Doesn't work perfectly, so if you want more answers, I'll be asking relevant questions soon.
I have a big problem and its driving me insane. I have a very simple piece of code that is supposed to copy a row and add it in below the active row plus a validation at the start of the code to check that you are allowed to add the row on that particular line.
The macro works perfectly when you first go in to the sheet. However, as soon as i enter anything in on any of the cells on the sheet the code bombs out with an automation error. Please say someone has found this before and has a fix for it?
The line it doesn't like is as shown here. Selection.Insert Shift:=xlDown
Sub Staffing_AddRow()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ActiveCell.Select
Cells(ActiveCell.Row, 223).Select
If ActiveCell.Value = "Y" Then
ActiveSheet.Unprotect Password:="PasswordGoesHere"
'------------------------------------
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Copy
Selection.Insert Shift:=xlDown
'------------------------------------
Cells(ActiveCell.Row, 13).Select
ActiveSheet.Protect Password:="PasswordGoesHere"
Else
If Response = MsgBox("You can't insert a row here!", _
vbCritical, "Warning") Then
Cells(ActiveCell.Row, 13).Select
End If
Cells(ActiveCell.Row, 13).Select
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
when it tries to paste that specific row in the worksheet I get Run-time error '-2147417848 (80010108)': Automation error the object invoked has disconnected from its clients.
Try this: Using With ActiveSheet
Sub Staffing_AddRow()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ActiveCell.Select
'CHANGES BEGIN HERE
With ActiveSheet
If .Cells(ActiveCell.row, 223).Value = "Y" Then
ActiveSheet.Unprotect Password:="PasswordGoesHere"
'------------------------------------
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Copy
Selection.Insert Shift:=xlDown
'------------------------------------
.Cells(ActiveCell.row, 13).Select
ActiveSheet.Protect Password:="PasswordGoesHere"
Else
If Response = MsgBox("You can't insert a row here!", _
vbCritical, "Warning") Then
.Cells(ActiveCell.row, 13).Select
End If
.Cells(ActiveCell.row, 13).Select
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End With
End Sub
See also: How to avoid using select statements in macros
I need the macro to go down a column in Excel and run the TEST procedure until the cells are empty. The TEST procedure always ends with the cell you started with selected. Here is how it looks manually but I would like to code it to run on a loop until the cell in column "B" is empty. Thanks in advance for any help. Here is what I am doing now (without a loop):
Sub NotLooped()
Windows("Pattern Scanv4.xlsm").Activate
Sheets("DATA").Select
Range("B2").Select
Application.Run ("TEST")
If ActiveCell.Offset(1, 0).Value = 0 Then
ElseIf ActiveCell.Offset(1, 0).Value > 0 Then
ActiveCell.Offset(1, 0).Range("A1").Select
Application.Run ("TEST")
End If
If ActiveCell.Offset(1, 0).Value = 0 Then
ElseIf ActiveCell.Offset(1, 0).Value > 0 Then
ActiveCell.Offset(1, 0).Range("A1").Select
Application.Run ("TEST")
End If
'etc.................
If ActiveCell.Offset(1, 0).Value = 0 Then
ElseIf ActiveCell.Offset(1, 0).Value > 0 Then
ActiveCell.Offset(1, 0).Range("A1").Select
Application.Run ("TEST")
End If
If ActiveCell.Offset(1, 0).Value = 0 Then
ElseIf ActiveCell.Offset(1, 0).Value > 0 Then
ActiveCell.Offset(1, 0).Range("A1").Select
Application.Run ("TEST")
End If
End Sub
Try this:
Sub Looped()
Dim sht As Worksheet, rng as Range
Set sht = Workbooks("Pattern Scanv4.xlsm").Sheets("DATA")
sht.Parent.Activate
sht.Select
Set rng = sht.Range("B2")
Do While Len(rng.value) > 0
rng.Select
TEST
Set rng = rng.offset(1,0)
Loop
End Sub
However it would be much better if your code didn't rely on a particular sheet being active or a given range being selected.
If you modify your TEST Sub to add a Range parameter then you can pass rng directly to it.
i.e. instead of:
Sub TEST()
...do something with selection/activecell
you can do this:
Sub TEST(rng As Range)
...do something with rng
and call it like this:
TEST rng
See How to avoid using Select in Excel VBA macros