Row selection and copying with a button - excel

I am trying to use a button in Excel to copy a certain range of cells from the active workbook to another workbook. The copying works perfectly when I specify a fixed range for each button in its assigned Macro but I'm stumped as to how to use the same Macro on each button and for the button's row number to indicate the row of data to be copied.
Every row contains 6 or so cells with the 7th containing the button. When the user presses this button the 6 cells on the same row as the row containing the pressed button need to be copied.
I am a complete novice when it comes to VBScript but much googling has got me this far:
Sheets("SurfaceThreats").Range("A4:F4")Copy_
Sheets("ORBAT").Cells(Rows.Count,1).End(x1Up).Offset(1,0)
Surely there is a more elegant solution than assigning a different, fixed range, Macro to every button.

See this screenshot
And this is the code for the Select Row(s) button
Option Explicit
Private Sub CommandButton1_Click()
Dim Ret As Range, rng As Range
Dim lRow As Long
On Error Resume Next
Set Ret = Application.InputBox("Please select the row", Type:=8)
On Error GoTo 0
If Not Ret Is Nothing Then
For Each rng In Ret.Rows
'~~> Get the last row in sheets "ORBAT" where you want to copy
With Sheets("ORBAT")
lRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With
'~~> Copy the rows
Sheets("SurfaceThreats").Range("A" & rng.Row & ":F" & rng.Row).Copy _
Sheets("ORBAT").Cells(lRow, 1)
Next
End If
End Sub

You can't create a generic button handler, but you can dynamically create the buttons and the macros to handle them. But it's quite a lot of work and you'll have to start creating macros dynamically. (this can cause problems with anti-virus software sometimes i think).
You could use the Worksheet_OnBeforeDoubleClick event to create "fake" buttons
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Target.Worksheet.Columns(1)) Is Nothing Then
MsgBox "You Clicked " & Target.Address
' call your generic handler here passing the Target.Address or Target.Row
Cancel = True
End If
End Sub
Using this code, if you double click any cell in the "A" column you'll get a message box saying what cell you clicked.
Its not the best of ideas, some users might not understand that it is a button.

Related

Copy & paste a range of cells and then mirror the values input

Not sure if this has been asked before can't seem to find the answer I'm looking for...
I have click buttons in place to copy a range of cells on one worksheet and then paste on another worksheet these work fine with the codes below:
Sub MWeek1()
Worksheets("Malton Weekly Input").Range("A3:K37").Copy
Worksheets("Malton Display").Range("BU12:CE46").PasteSpecial Paste:=xlPasteValues
End Sub
Sub MWeek2()
Worksheets("Malton Weekly Input").Range("A40:K74").Copy
Worksheets("Malton Display").Range("BU12:CE46").PasteSpecial Paste:=xlPasteValues
End Sub
I have buttons for Weeks 1 through to 5.
What I'm now wanting to achieve is to mirror or link the cells after the button has been clicked so that both worksheets are updated. So if the user clicks the Week 1 button on the display sheet, the values from the Week 1 range on the weekly input sheet are copied & pasted across, and then if the user was to add anything on the display sheet it would automatically update the week 1 range on the weekly input sheet.
The idea being that the user can switch back and forth between weeks using the command buttons & update them without leaving the display sheet.
Apologies if I haven't made this clear enough will provide more info if needed.
EDIT:
Ok so I have managed to mirror the range of cells using the below code on the Malton Display sheet:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim colNum As Long, rowNum As Long
If Not Intersect(Target, [MDisplay]) Is Nothing Then
colNum = Target.Column - [MDisplay].Cells(1, 1).Column + 1
rowNum = Target.Row - [MDisplay].Cells(1, 1).Row + 1
Application.EnableEvents = False
[MaltonWeek1].Cells(rowNum, colNum).Value = Target.Value
End If
Application.EnableEvents = True
End Sub
I have the same code in Malton Weekly Input sheet but with the named areas reversed.
I'm wondering if I can trigger these worksheet change events to mirror different ranges depending on the value of a cell on the display sheet?
Worksheets("Malton Display").Range("BU10:CE10")
Thanks

Copy and paste cell value to another sheet based on hyperlink click

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.

Show/hide number of rows based on "n"

I am trying to show/hide a number of rows based on "n".
The rows I'm trying to show or hide span from rows 21 to 70. My input cell for "n" is B14.
Say if B14 is 2 then I only want rows 21 and 22 to be visible (23 to 70 hidden). If B14 is 48 then rows 21 to 68 visible and so forth.
Can someone help me with the macro required to achieve this?
Try this code, please. It will automatically hide the rows according to the changed value in "B14". Copy the code in the sheet module. In order to do that, select the sheet to be processed, right click on its page and choose "View Code". Copy the code there, go back in the sheet, start playing with values in "B14" and send some feedback about its behavior:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B14")) Is Nothing Then
Dim lastRow As Long, visRows As Long
If IsNumeric(Range("B14").Value) Then
visRows = Range("B14").Value
Else
MsgBox "In range ""B14"" must be a number!": Exit Sub
End If
If visRows = 50 Then
lastRow = 69
Else
lastRow = 70
End If
Range("A:A").EntireRow.Hidden = False 'make all rows visible
Range(Range("A21").Offset(visRows), Range("A" & lastRow)).EntireRow.Hidden = True
End If
End Sub
The following VBA code should work
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngWatched As Range, n As Long
Set rngWatched = Me.Range("B14")
If Not Intersect(Target, rngWatched) Is Nothing Then
With Me.Range("A21:A70")
.EntireRow.Hidden = True
n = rngWatched.Value
If n > 0 Then
.Cells(1, 1).Resize(n, 1).EntireRow.Hidden = False
End If
End With
End If
End Sub
To use the code, please follow these steps:
Press Alt+F11. This will take you to the VBA editor window
On the left hand side you will see a project explorer
Expand VBAProject(YOUR_EXCEL_FILENAME)
Expand Microsoft Excel Objects
Double-click on the relevant sheet. This will open the sheet class page
Paste the code here
Close the VBA editor window and go back to excel
Make sure the file is then saved as Excel Macro-Enabled workbook (*.xlsm)

VBA code to move entire rows from one sheet to 3 different sheets based on cell values from dropdown list

I am trying to use VBA code in order to move entire rows from sheet1 named "New Projects" to 3 different sheets, based on cell value picked from in cell dropdown list in sheet1.
I am not a coder but I could understand a little and fond a piece of code somewhere on the internet.
So far I found the code that can move a row from my sheet1 ("New Projects") to other sheet named "Prio1", if the cell value picked from dropdown list becomes "Prio 1" (meaning that I am moving that new project (entire row) to sheet "Prio1" because it has priority number 1.
But I have even the sheets named Prio2 and Prio3 where I need to move the rows when the value in the cell is "Prio 2" or "Prio 3", and I dont know how to do it.
If I just copy/paste same code in the editor and only change sheet names then I get some error message "Ambiguous name Worksheet_Change" and it doesn't work.
This is the piece of code that I found and it works for moving rows to Prio1:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim answer As Integer
Dim lngRow As Long, ws As Worksheet, nextrow As Long
If Target.Cells.Count > 1 Then Exit Sub
Application.ScreenUpdating = False
If Not Intersect(Target, Columns("M:M")) Is Nothing Then
If Target.Value = "Prio 1" Then
lngRow = Target.Row
On Error Resume Next
With ThisWorkbook
Set ws = Worksheets("Prio1")
If ws Is Nothing Then .Worksheets.Add().Name = "Prio1"
nextrow = Worksheets("Prio1").Cells(Rows.Count, "A").End(xlUp).Row + 1
End With
With Sheet1 'code name
answer = MsgBox("Ska Almin flytta ärendet till fliken Prio1?", vbYesNo + vbQuestion)
If answer = vbYes Then
.Range("A" & lngRow).EntireRow.Copy Destination:=Worksheets("Prio1").Range("A" & nextrow)
.Range("A" & lngRow).EntireRow.Delete shift:=xlUp
Else
Worksheets("Nya ärende").Range("M:M").ClearContents 'or do nothing
End If
End With
End If
End If
Application.CutCopyMode = False
Application.ScreenUpdating = True
Set ws = Nothing
End Sub
Now I need help to somehow add the equivalent code for "Prio2" anf "Prio3".
Can someone please help me out?
Almin
The error Ambiguous name Worksheet_Change means exactly what it sounds like (or what Google Translate would tell you it means -- tvetydig or mångtydig).
There is another procedure in your project that already has the name Worksheet_Change.
To find it from the VBA Editor, press CTRL+F and enter Worksheet_Change, click Current Project and use Find Next as required to figure out why the name is being used twice.
You'll have to either get rid of one of the procedures with duplicate names, or rename one, or combine the two together.
A good tutorial: Excel VBA For Complete Beginners

Adjust zoom based on resolution via FollowHyperlink event

My sheet has data in columns A to Z. I have hyperlinks in rows 13 to 49 that jump to specific cells in rows below. For example, the hyperlink in row 13 will jump to row 229.
The hyperlinks are fine until I do a presentation on another machine with a different resolution. Instead of jumping to row 229, it shows row 248.
I have tinkered with this and this but have had no success yet. Also tried this less related answer to see if I can trick excel. I have also tried the below code:
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
r = ActiveCell.Row
Range(Cells(r, 1), Cells(r, 26)).Select
'Target.Range.Select
ActiveWindow.Zoom = True
If you are looking to put A229 into the top-left corner of the visible worksheet area, then fool Excel by first going past the visible portion of the worksheet that you want and come back to it.
In A13, put a hyperlink that goes to A1229, not A229.
Sub setup_Hyperlinks()
With Worksheets("Sheet1")
With .Range("A13")
.Hyperlinks.Delete
.Hyperlinks.Add Anchor:=.Cells(1), Address:="", SubAddress:="Sheet1!A1229", _
ScreenTip:="Jump to row 229", TextToDisplay:="Row 229"
End With
End With
End Sub
Note that the actual subaddress target is A1229, not A229.
Right-click the worksheet's name tab and choose View Code. When the VBE opens, paste one of the following into the worksheet code sheet titled something like Book1 - Sheet1 (Code).
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells(1, 1).Row > 1000 Then 'this will depend on how you craft the method for your own purposes
Application.Goto _
Reference:=Target.Cells(1, 1).Offset(-1000, 0)
'[optional] move one row down for personal aesthetics
'ActiveWindow.SmallScroll Down:=-1
End If
End Sub
... or,
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
If ActiveCell.Row > 1000 Then 'this will depend on how you craft the method for your own purposes
Application.Goto _
Reference:=ActiveCell.Offset(-1000, 0)
'[optional] move one row down for personal aesthetics
'ActiveWindow.SmallScroll Down:=-1
End If
End Sub
Use one or the other but not both. The former seems to have marginally less screen 'flash' on my system.
It just hit me. Check out Windows(1).VisibleRange.Rows.count
You can see how many rows are displayed, go down so the link target will be at the top. This should be accurate regardless of the resolution.
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim iActive As Integer
Dim lBottom As Long
Dim ws As Excel.Worksheet
Set ws = ActiveWorkbook.Sheets("Sheet1")
'Get the number of rows showing
iActive = Windows(1).VisibleRange.Rows.count
'Move to center of the active window
lBottom = ActiveCell.Row + (iActive / 2) - 1
ws.Range("A" & lBottom).Activate
End Sub

Resources