I have a macro (ApplyFilter) that filters through many worksheets based on a date I enter into cell B1 on another worksheet (Grand Totals). That macro is:
Sub ApplyFilter() 'Filters all worksheets except worksheet1 for date entered into _
'Grand Totals!B1
Dim WS_Count As Integer
Dim I As Integer
Dim FilterRange As Variant
FilterRange = Range("'Grand Totals'!B1")
' Set WS_Count equal to the number of worksheets in the active
' workbook.
WS_Count = ActiveWorkbook.Worksheets.Count
' Begin the loop.
For I = 2 To WS_Count
Sheets(I).Select
ActiveSheet.AutoFilterMode = False 'Remove any existing filters
Worksheets(I).Range("A2").AutoFilter Field:=1, Criteria1:=Range("'Grand Totals'!B1").Text
Next I
Sheet1.Activate
End Sub
When I execute this macro manually, it executes and filters as it should. However, when I call this macro from another sub:
Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("B1")) Is Nothing Then _
Call ApplyFilter
End Sub
I get a "Macros" window that offers a list of macros available. I can select the "ApplyFilter" macro and click Run and the Macro executes and filters the worksheets as I desire.
I found many references to automatically executing a macro from within a sub, but none refer to the "Macros" window, from which I now must select the macro to run. Instead, when I enter a date in cell B1 of the "Grand Totals" worksheet and hit enter, sub worksheet_change(ByVal Target As Range) should automatically call "ApplyFilter" and apply the date filter to the many worksheets.
I have created a button and used Button_Click to call "ApplyFilter", and all is well. But, it seems more intuitive to enter the date and then press Enter to execute the macro. I could put up with the Button_Click method, but I'm trying to learn VBA firstly, and I'm just stubborn enough to want to learn how to make it work, and I do not want settle just for what will work.
Sheet Code must be in Grand Totals sheet
right click your Grand Totals sheet tab
View Code
Ensure the code below is pasted in here
altf11 back to Excel
Grand Totals Sheet Code
Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("B1")) Is Nothing Then Call ApplyFilter
End Sub
more efficient filter code
Sub ApplyFilter()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
If ws.Name <> "Grand Totals" Then
ws.AutoFilterMode = False
ws.Range("A2").AutoFilter Field:=1, Criteria1:=Range("'Grand Totals'!B1").Text
End If
Next
End Sub
Related
Hope you can help me.
I want to copy and paste a cells value based on when you click a hyperlink on that cell.
So for example, I have a sheet called Form1, I want to click on an ID in column A it will then copy the value of that cell and paste it to B2 in sheet1 and then take me to sheet 1.
Currently I have a macro that allows me to click on an active cell and then press a button which then does what is mentioned above. I just think a hyperlink press would be more user friendly and would result in less errors.
Here is the code I have at the moment:
Sub Rectangle13_Click()
ActiveCell.Copy Destination:=Sheets(“Sheet1”).range(“B2”)
Worksheets(“Sheet1”).Activate
End Sub
Any help would be appreciated! Thank you
Worksheet FollowHyperLink
Copy this code to the sheet module of worksheet Form1. From there, run the second sub to convert the A column to hyperlinks.
Click away.
Option Explicit
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
If Not Intersect(Columns("A"), Target.Range) Is Nothing Then
Me.Parent.Worksheets("Sheet1").Range("B2").Value = Target.Range.Value
End If
End Sub
' Run this to create hyperlinks out of the values in column 'A'
' which will point to cell 'B2' in 'Sheet1'. You can then reformat
' the cells (remove underline, change font color, ...).
Private Sub CreateHyperlinks()
Dim lRow As Long: lRow = Range("A" & Rows.Count).End(xlUp).Row
Dim cell As Range
For Each cell In Range("A2:A" & lRow).Cells
cell.Hyperlinks.Add cell, "", "Sheet1!B2", , CStr(cell.Value)
Next cell
End Sub
It is inconvenient to use Hyperlik, I think. If you try changing the cell value, you cannot simple click it and write something... But if you want that, you can create such a hyperlink in the next way:
Sub testAddHyperlink()
Dim DestSh As Worksheet
Set DestSh = Sheets("Sheet1") 'you can use any sheet name here
ActiveSheet.Hyperlinks.Add Range("A1"), Address:="", SubAddress:="'" & DestSh.name & "'" & "!A1"
'it will keep the existing cell value
End Sub
Then, please copy the next event code in the sheet code module (where the hyperlink exists):
Option Explicit
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim rngCopy As Range, shDest As Worksheet
Set shDest = Sheets("Sheet1") 'you may use here any sheet name
shDest.Range("B2").value = Target.Parent.Value 'the sheet where the hyperlink targets, is already activated...
End Sub
If you want to use the BeforeDoubleClick approach, paste this code into your Form1 worksheet object in the VBA editor ...
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Cells.Count = 1 And Target.Cells(1, 1).Column = 1 Then
Cancel = True
With ThisWorkbook.Worksheets("Sheet1")
.Range("B2") = Target.Value
.Activate
End With
End If
End Sub
... naturally, this is a base example and you may need to modify it accordingly. For example, when you double click, you may want to ignore the first row if it's a header and not invoke the core parts of the logic.
That will then do what you want.
I am designing a time report for my colleagues. There are cells which contain a (hidden) formula but are unprotected because I need the user to still be able to manually override the formula.
Now, if a user enters his/her own content and then deletes it again, the cell is empty, which is what I don't want, as it will only lead to confusion.
I want to write a VBA macro which recognizes if the cell contents in a previously declared range are deleted / empty and if they are deleted / empty, then a formula from another (password-protected and hidden) cell should be copied to the empty cell.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRange As Range
Set myRange = Intersect(Range("F9:I108"), Target)
If Not myRange Is Nothing Then
'I'm guessing something with WorksheetFunction and possibly CountA,
'but I don't know how to make it work
End If
End Sub
The formulas which should be entered if the content of a cell (or of multiple cells) is deleted is always in line 117 (same worksheet). For example, if the user deletes G50, then G117's formula should be copied into G50 in the same way you usually copy formulas in Excel (so if there's a non-$-reference in G117 that points to A117, it should then point to A50 after the formula is copied to G50).
If possible, I want to work without loops--they always take so long to execute.
Thanks in advance!
Here is a super simple example that involves only 3 cells, A1, A2 and A3. You must modify this to accommodate your formula-cells.
We first create a secret worksheet (called secret). We place the formulas from A1 through A3 from the main worksheet into the secret sheet, but we store them as Strings rather than Formulas:
Then we put the following worksheet event macro in the main sheet:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Range("A1:A3")
If Intersect(Target, rng) Is Nothing Then Exit Sub
If Target.Count <> 1 Then Exit Sub
If Target.Value <> "" Then Exit Sub
Application.EnableEvents = False
Target.Formula = Sheets("secret").Range(Target.Address).Value
Application.EnableEvents = True
End Sub
The sub monitors changes to the three cells and if any of them are cleared, that formula will be restored from the secret worksheet.
Because it is worksheet code, it is very easy to install and automatic to use:
right-click the tab name near the bottom of the Excel window
select View Code - this brings up a VBE window
paste the stuff in and close the VBE window
If you have any concerns, first try it on a trial worksheet.
If you save the workbook, the macro will be saved with it.
If you are using a version of Excel later then 2003, you must save
the file as .xlsm rather than .xlsx
To remove the macro:
bring up the VBE windows as above
clear the code out
close the VBE window
To learn more about macros in general, see:
http://www.mvps.org/dmcritchie/excel/getstarted.htm
and
http://msdn.microsoft.com/en-us/library/ee814735(v=office.14).aspx
To learn more about Event Macros (worksheet code), see:
http://www.mvps.org/dmcritchie/excel/event.htm
Macros must be enabled for this to work!
Here's another possible answer. In order to copy the formula and have it maintain the "relative addressing" of the formula, you need to copy using the R1C1 notation. So a quick sub for this could look like
Option Explicit
Sub RestoreFormula(ByRef emptyCell As Range)
Dim formulaWS As Worksheet
Dim formulaCell As Range
Set formulaWS = ThisWorkbook.Sheets("Sheet1")
Set formulaCell = formulaWS.Range("A17")
emptyCell.FormulaR1C1 = formulaCell.FormulaR1C1
End Sub
The important line here is the emptyCell.FormulaR1C1 = formulaCell.FormulaR1C1 part.
Then, over in the Worksheet_Change event it could look like this
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim checkRange As Range
Set checkRange = ActiveSheet.Range("A1:A9")
If Not Intersect(checkRange, Target) Is Nothing Then
Dim changedCell As Range
For Each changedCell In Target
If IsEmpty(changedCell) Then
RestoreFormula changedCell
End If
Next changedCell
End If
End Sub
If anyone else ever has the same problem and maybe wants to use my solution, which is a combination of PeterT's and Gary's Student's suggestions (thank you both so much):
First I created a new worksheet, in which I copied all of the formulas I wish to retain. I made sure to copy them to the exact same cell as in the original sheet.
Then I appended this code to the original worksheet:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bereich1 As Range
Set Bereich1 = Range("F9:I108") 'Do NOT enter multiple, non-contiguous ranges here! It crashes Excel!
If Not Intersect(Bereich1, Target) Is Nothing Then
Dim changedCell1 As Range
For Each changedCell1 In Target
If changedCell1 = "" Then
changedCell1.Formula = Sheets("Tagebuch_secret").Range(changedCell1.Address).Formula
End If
Next changedCell1
End If
Dim Bereich2 As Range
Set Bereich2 = Range("E112") 'instead duplicate the code snippet
If Not Intersect(Bereich2, Target) Is Nothing Then
Dim changedCell2 As Range
For Each changedCell2 In Target
If changedCell2 = "" Then
changedCell2.Formula = Sheets("Tagebuch_secret").Range(changedCell2.Address).Formula
End If
Next changedCell2
End If
End Sub
This works fine for every scenario in which cell contents get deleted, both if the user deletes contents of a single or multiple cells!
My next step is to make the _secret sheet very hidden, password-protect the workbook structure and then password-protect my vba project. Then only people who know the password (me) can destroy my file :)
I am trying to create a workbook where if I change a dropdown on 1 sheet, it automatically updates that same dropdown on a second sheet. These dropdowns will represent different scenarios and my purpose in creating this is to allow the end-user the ability to change the scenario dropdown from any sheet, rather than just one.
I used this reference to create a VBA for changing 1 dropdown -Original VBA code referenced - and it worked correctly (See example workbook to download). However, now I want to add the other 2 dropdowns so that if any changes are made to them it updates accordingly.
I'm also open to other solutions if you know of something better.
Sorry if this question was elementary -- I am new to VBA.
Using the example from the Original VBA code referenced, if you were looking to apply this rule to 2 sets of drop downs (4 total), instead of 1 set - you would duplicate the snippet from "If Not Intersect(..." to "..End if" and then update the reference to the 2nd set of cells.
EXAMPLE:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim targetSheet As Worksheet
If Not Intersect(Target, Range("A1")) Is Nothing Then ' watch only cell A1
Set targetSheet = ActiveWorkbook.Worksheets("Sheet2") ' define the sheet to copy to
On Error Resume Next
Application.EnableEvents = False
targetSheet.Range("B1") = Target.Value ' copy to cell B1 on the target sheet
Application.EnableEvents = True
End If
If Not Intersect(Target, Range("A2")) Is Nothing Then ' watch only cell A1
Set targetSheet = ActiveWorkbook.Worksheets("Sheet2") ' define the sheet to copy to
On Error Resume Next
Application.EnableEvents = False
targetSheet.Range("B2") = Target.Value ' copy to cell B1 on the target sheet
Application.EnableEvents = True
End If
End Sub
You would then repeat for the other worksheet.
I have Excel Workbook in which there are 4 sheet which has two cell name start date and end date, whose values should be same across all 4 sheet, I want that If I change the value in anyone of the sheets the other three sheets automatically update that values. And vice versa.
Use the Workbook_SheetChange event to update the same cells on every worksheet if any one of the cells changes.
For example, if each sheet has the named ranges start_date and end_date (where their scope is limited to that sheet only), changes made to any start_date or end_date range on any sheet will update the corresponding range on all the other sheets.
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error GoTo SafeExit
Application.EnableEvents = False
Dim ws As Worksheet
With Sh
If Not Intersect(Target, .Range("start_date")) Is Nothing Then
For Each ws In Worksheets
ws.Range("start_date").Value = Target.Value
Next ws
End If
If Not Intersect(Target, .Range("end_date")) Is Nothing Then
For Each ws In Worksheets
ws.Range("end_date").Value = Target.Value
Next ws
End If
End With
SafeExit:
Application.EnableEvents = True
End Sub
If you are referring to the cells by their address and not by a defined name, something like this could work:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error GoTo SafeExit
Application.EnableEvents = False
Dim ws As Worksheet
With Sh
' "A1" is the start date, change as needed
If Not Intersect(Target, .Range("A1")) Is Nothing Then
For Each ws In Worksheets
ws.Range("A1").Value = Target.Value
Next ws
End If
' "B1" is the end date, change as needed
If Not Intersect(Target, .Range("B1")) Is Nothing Then
For Each ws In Worksheets
ws.Range("B1").Value = Target.Value
Next ws
End If
End With
SafeExit:
Application.EnableEvents = True
End Sub
This code goes in the ThisWorkbook module in the VBA editor.
You don't need VBA for this but rather named ranges. Put your cursor in the input cell, say E5, for start_date and then click in the named range box (in the upper left corner of the worksheet grid, directly above column A). Type start_date over E5 and hit Enter. Now, cell E5 is named start_date. If you use =start_date anywhere else in the workbook, it will refer to the current contents of cell E5. If you want to edit the named ranges in any way, go to the ribbon menu FORMULAS -> Name Manager.
If you want to do this with VBA for the sole purpose of learning VBA, I would recommend taking a VBA course instead. Udemy has some good ones that often go on sale for about $10, and I'm sure that there are plenty of free resources elsewhere as well.
I have an excel workbook that contains multiple sheets within it. For the sake of this question, the sheets are named Sheet1, Sheet2, Sheet3, and so on. I would like to have Column A from sheet1 be replicated throughout the rest of the sheets and as new cells are added to column A in sheet1, they would automatically be entered into the other sheets within the workbook. I would prefer not to have a set "ending range; ie: A100000" for this. For example, if I enter First in cell A1 of Sheet1, the word "First" should now also appear in cell A1 of Sheet2. I have used the following code, and it does not seem to work. Any help would be greatly appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
Call UpdateFromSheet1
End Sub
Sub UpdateFromSheet1(ByVal Sh As Object, ByVal Target As Range)
If Sh.CodeName = "Sheet1" Then
If Not Intersect(Target(1, 1), Range("A1:A1000")) Is Nothing Then
Sh.Range("A1:A1000").Copy Sheet2.Range("A1")
End If
End If
End Sub
UPDATE
For a clean looking Non-VBA solution, you can use the formula references that others have mentioned, but enter it like this.
In Sheet2 cell A1 = If(Sheet1!A1="","",Sheet1!A1) That way you can fill down on the whole of column A and not have "0" pop-up if Sheet1 has a rows without data.
I think you have the general idea, but I suspect you may not have your code in the right place.
For the VBA solution:
First, you don't need to call the sub from Worksheet_Change event (unless of course you want to use this sub for other reasons and pass variables to it. Second, if you place this code in the worksheet object in the VBE of the "Sheet1" it will do as you wish:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("A")) Is Nothing Then
Dim wks As Worksheet
For Each wks In Sheets(Array("Sheet2", "Sheet3"))
Target.EntireColumn.Copy wks.Columns(1)
Next
End If
End Sub
This is a very basic use for excel. You can set cells equal to each other. You in no way would need a VBA macro for this.
If you put this in cell "A1" on Sheet2 and Sheet3:
=Sheet1!A1
Then when you type something into A1, it will be "mirrored" on sheets 2 and 3. You can autofill this down to all the cells in column A on sheets 2 and 3.
Are you familiar with the term autofill?
If you don't understand anything I just said and you want to just run a macro then run this and start typing away:
Sub MacroBasicQuestion()
Dim wbk As Workbook
Set wbk = ThisWorkbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Set ws1 = wbk.Sheets(1)
Set ws2 = wbk.Sheets(2)
Set ws3 = wbk.Sheets(3)
Dim cell As Range
Set cell = ws2.Range("A1:A1")
ws2.Select
cell.FormulaR1C1 = "=Sheet1!RC"
cell.Select
Selection.AutoFill Destination:=Range("A:A"), Type:=xlFillDefault
Set cell = ws3.Range("A1:A1")
ws3.Select
cell.FormulaR1C1 = "=Sheet1!RC"
cell.Select
Selection.AutoFill Destination:=Range("A:A"), Type:=xlFillDefault
End Sub
Good Luck.