I want a button click to
record the address of the active cell I have selected in sheet 1, and place it into the next empty row in Column "B" on sheet 2.
On the button click as well, I wish for a MsgBox to display the corresponding row of Column "A", which contains reference numbers.
So far I have a working button, but my coding abilities are limited and this is all I have:
Private Sub CellReferenceBtn_Click()
MsgBox "The Active Cell Row and Column is " & ActiveCell(Row + 1, Column + 1).Address
End Sub
Any help is appreciated!
Here you go:
Private Sub CellReferenceBtn_Click()
With ActiveCell
Sheet2.[offset(b1,counta(b:b),)] = .Address
MsgBox Sheet1.Cells(.Row, 1)
End With
End Sub
It isn't clear on whether you require the worksheet name as well as the cell address. The worksheet name would make a full cell range address but if your intention is to use only the cell portion for something else then the worksheet name will just get in the way. Here are three possibilities.
'just the cell address without the worksheet name
Private Sub CommandButton1_Click()
With Worksheets("Sheet2")
.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = _
Selection(1).Address
'alternate for a larger selection of cells
'.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = _
Selection.Address
'pass focus back to the worksheet cells
Selection.Select
End With
End Sub
'cell range and the worksheet name
Private Sub CommandButton1_Click()
Dim addr As String
With Worksheets("Sheet2")
addr = Selection(1).Address(external:=True)
'alternate for a larger selection of cells
addr = Selection.Address(external:=True)
.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = Chr(39) & _
Replace(addr, _
Mid(addr, InStr(1, addr, Chr(91)), _
InStr(1, addr, Chr(93)) - InStr(1, addr, Chr(91)) + 1), _
vbNullString)
'pass focus back to the worksheet
Selection.Select
End With
End Sub
'full external path, worksheet name and cell range
'you can use this locally and it will abbreviate itself to what is necessary
Private Sub CommandButton1_Click()
With Worksheets("Sheet2")
.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = _
Selection(1).Address(external:=True)
'alternate for a larger selection of cells
.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = _
Selection.Address(external:=True)
Selection.Select
End With
End Sub
Something like
Sub AddForm()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheets(1)
Set ws2 = Sheets(2)
'check active sheet is sheet 1
If ActiveCell.Parent.Name = ws1.Name Then
ws2.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = ActiveCell.Address
MsgBox ActiveCell.Address
End If
End Sub
Related
I’m wanting to know if this is possible, and how would I go about doing so:
I’d like to be able to double click a cell (in column Z), reference what is in Column G of that same row, and then find and set focus from the info found in column G on another sheet.
So when I double click the cell in Z1 for example, it looks for what information is in G1 and finds it on another sheet and sets focus to that new cell.
Is this possible?
Thanks
Yes, you need to implement Worksheet_BeforeDoubleClick event handler then you may do anything you like, handler is an event of Worksheet object. Do your main code in Module code to keep things reusable across multiple sheets.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Call Module1.onDrillDownToData(Target)
End Sub
- - -
Public Function onDrillDownToData(ByRef sender As Range)
Dim ws as worksheet
Dim iCol As Long
Dim iRow As Long
Dim dt As Date
set ws = sender.Parent
' do anything you want with worksheet
' sender is the origin cell
iCol = Sender.Column
iRow = Sender.Row
dt = Now()
ws.Cells(iRow, iCol).Value = "'" & Format(dt, "yyyy\-MM\-dd", vbMonday)
ws.Cells(iRow + 1, iCol).Value = "'" & Format(dt, "hh\:nn\:ss", vbMonday)
set ws = Application.Worksheets("TargetSheet")
ws.Activate
ws.Range("A5").Activate
End Function
Worksheet BeforeDoubleClick
Copy the following code into the sheet module of the sheet where you are going to double-click (In VBE in the project explorer double-click on the appropriate sheet to open its code window).
Before exiting VBE, adjust the constants, especially the destination worksheet name (wsName, the name in parentheses), in the code.
The Code
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' Define constants.
Const wsName As String = "Sheet2" ' Destination Worksheet Name
Const SourceColumn As String = "Z" ' Source Column String
Const CriteriaColumn As String = "G"
' Not sure if this is even possible.
If Target.Rows.Count > 1 Then Exit Sub
If Not Intersect(Target, Columns(SourceColumn)) Is Nothing Then
Dim Criteria As Variant
Criteria = Cells(Target.Row, CriteriaColumn)
If Not IsError(Criteria) And Not IsEmpty(Criteria) Then
Dim cel As Range
With ThisWorkbook.Worksheets(wsName)
Set cel = .Cells _
.Find(What:=Criteria, _
After:=.Cells(.Rows.Count, .Columns.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
MatchCase:=False) ' Change to True is necessary
If Not cel Is Nothing Then
.Activate
cel.Select
End If
End With
End If
End If
End Sub
I have an Excel sheet with 5 tabs, column A in each is where I want a clickable cell.
When that cell is clicked, I want it to cut the 4 cells to the right of it on the same row and paste it on the next tab.
Clicking A1 would cut B1, C1, D1, E1 and paste it on the next tab, on the next empty row.
Same with the next tab until that row has made it to the final tab.
All the data is on the first sheet, all the others are empty.
Once I click on the first sheet I want it to move to the next one, then when I click it on the next one I want it to move to the third one.
So far I have code that creates hyperlinks on the cells I highlight, but it displays (sheet name! cell number). I want to display a specific txt instead, like (complete) or (received). The display varies for each tab.
The code I have in the first sheet moves the cut row to the second sheet.
I tried pasting that code in the next sheet to move it to the third sheet but I get an error.
Code in module
Sub HyperActive()
Dim nm As String
nm = ActiveSheet.Name & "!"
For Each r In Selection
t = r.Text
addy = nm & r.Address(0, 0)
ActiveSheet.Hyperlinks.Add Anchor:=r, Address:="", SubAddress:= _
addy, TextToDisplay:=r.Text
Next r
End Sub
Code in sheet
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim r As Range
Set r = Range(Target.SubAddress)
r.Offset(0, 1).Resize(1, 4).Cut
Sheets("Wash Bay").Select
Worksheets("Wash Bay").Range("B" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
End Sub
I'd suggest using the Workbook_SheetFollowHyperlink event here. This is the workbook-level event, as opposed to the worksheet-level Worksheet_FollowHyperlink event.
From the docs:
Occurs when you choose any hyperlink in Microsoft Excel...
Parameters
Sh : The Worksheet object that contains the hyperlink
Target: The Hyperlink object that represents the destination of the hyperlink
Add the following code to the ThisWorkbook module (not the sheet code module).
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
If Sh.Index = Me.Worksheets.Count Then Exit Sub ' Do nothing if `Sh` is the last worksheet
Dim nextWs As Worksheet
Set nextWs = Me.Worksheets(Sh.Index + 1)
With nextWs
Dim lastRow As Long
lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
End With
Dim rng As Range
Set rng = Sh.Range(Target.SubAddress)
rng.Offset(, 1).Resize(1, 4).Cut Destination:=nextWs.Range("B" & lastRow + 1)
Application.CutCopyMode = False
End Sub
IMPORTANT NOTE: In its current state, this assumes that the workbook only has worksheets (no chart sheets, for example).
EDIT: You can use this revised code if the workbook contains other sheet types besides worksheets:
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
Dim indx As Long
indx = GetWorksheetIndex(Sh)
If indx = Me.Worksheets.Count Then Exit Sub
Dim rng As Range
Set rng = Sh.Range(Target.SubAddress)
Dim nextWs As Worksheet
Set nextWs = Me.Worksheets(indx + 1)
With nextWs
Dim lastRow As Long
lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
End With
rng.Offset(, 1).Resize(1, 4).Cut Destination:=nextWs.Range("B" & lastRow + 1)
Application.CutCopyMode = False
End Sub
Private Function GetWorksheetIndex(ByVal ws As Worksheet) As Long
Dim w As Worksheet
For Each w In ws.Parent.Worksheets
Dim counter As Long
counter = counter + 1
If w.Name = ws.Name Then
GetWorksheetIndex = counter
Exit Function
End If
Next w
End Function
2nd EDIT:
I think you can rewrite HyperActive to something like this:
Sub HyperActive(ByVal rng As Range)
Dim ws As Worksheet
Set ws = rng.Parent
Dim fullAddress As String
fullAddress = "'" & ws.Name & "'!" & rng.Address
ws.Hyperlinks.Add Anchor:=rng, Address:="", SubAddress:=fullAddress, TextToDisplay:=rng.Text
End Sub
Then in the main Workbook_SheetFollowHyperlink code, add the following line:
HyperActive rng:=nextWs.Range("A" & lastRow + 1)
I've got Workbook where I got names and hours worked of employees. I'm looking for comparing rows in one worksheet (Range B6:CC6) and find it in another with selection on cell with employee name (Range A1:A5000) when I change sheets from 1 to 2.
Tried some Range.Find and others, no idea how to do it
Public Sub FindPosition()
Dim Actcol As Integer, Pos As Range, Name As Range
Actcol = ActiveCell.Column
MsgBox "ActiveCell is" & Actcol
Set Pos = Cells(6, Actcol)
MsgBox Pos
Pos.Select
If Worksheets("Sheet2").Activate Then
Worksheets("Sheet2").Range("A1:AA5100").Select
Set Name = Selection.Find(Pos, LookIn:=xlValues)
End If
End Sub
First, if you want to trigger some macro by activation of Sheet2, you need to handle Activate event of Sheet2. This can be done by declaring subroutine in Sheet module like this.
Private Sub Worksheet_Activate()
'Codes you want to be run when Sheet2 is activated.
End Sub
Second, a simple way to find a cell with specific value is to use WorksheetFunction.Match. For example,
Dim SearchInRange As Range
Set SearchInRange = Range("A1:A5000")
Dim EmployeeName As Variant
EmployeeName = ... 'Actual employee name you want to search
On Error GoTo NotFound
Dim Index As Variant
Index = WorksheetFunction.Match(EmployeeName, SearchInRange, 0)
On Error GoTo 0
SearchInRange.Cells(Index).Select
GoTo Finally
NotFound:
' Handle error
Finally:
Range.Find may also work, but remember it has the side effect of changing the state of "Find and Replace" dialog box.
This may helps you
Option Explicit
Sub test()
Dim i As Long, LastRowA As Long, LastRowB As Long
Dim rngSearchValues As Range, rngSearchArea As Range
Dim ws1 As Worksheet, ws2 As Worksheet
'Set you worksheets
With ThisWorkbook
'Let say in this worksheet you have the names & hours
Set ws1 = .Worksheets("Sheet1")
'Let say in this worksheet you have the list of names
Set ws2 = .Worksheets("Sheet2")
End With
'Find the last row of the column B with the names from the sheet with names & hours
LastRowB = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row
'Find the last row of the column A with the names from the sheet with list of names
LastRowA = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
'Set the range where you want to check if the name appears in
Set rngSearchArea = ws2.Range("A1:A" & LastRowA)
'Loop the all the names from the sheet with names and hours
For i = 6 To LastRowB
If ws1.Range("B" & i).Value <> "" Then
If Application.WorksheetFunction.CountIf(rngSearchArea, "=" & ws1.Range("B" & i).Value) > 0 Then
MsgBox "Value appears"
Exit For
End If
End If
Next i
End Sub
Oh right, I found solution. Thanks everyone for help.
Public Sub Position()
Dim Accol As Integer
Dim Pos As Range
Dim name As Range
ActiveSheet.name = "Sheet1"
Accol = ActiveCell.Column
Set Pos = Cells(6, Accol)
Worksheets("Sheet2").Activate
Worksheets("Sheet2").Range("a1:a5000").Select
Set name = Selection.Find(What:=Pos, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
name.Select
End Sub
Last thing I would like to do which I cannot solve is where do I write automatically script running when I choose Sheet2?
I have a spreadsheet that is updated regularly. Therefore the column header positions change regularly. eg. today "Username" is column K, but tomorrow "Username" might be column L. I need to add a new column to the right of "Username" but where it changes I cannot refer to as cell/column reference.
So far I have:
Dim rngUsernameHeader As Range
Dim rngHeaders As Range
Set rngHeaders = Range("1:1") 'Looks in entire first row.
Set rngUsernameHeader = rngHeaders.Find("Username")
When I go to add a new column to the right of it, I'm selecting that row but it's going back to cell/column references...
Columns("K:K").Select
Selection.Insert Shift:=xlToRight
Range("K1").Select
ActiveCell.FormulaR1C1 = "Role"
How can I perform this step with a macro?
edit: I think need to give that Column a header name and begin populating the row with data - each time I do begins the cell references which I want to avoid wherever possible.
Many thanks in advance.
How about:
Sub qwerty()
Dim rngUsernameHeader As Range
Dim rngHeaders As Range
Set rngHeaders = Range("1:1") 'Looks in entire first row.
Set rngUsernameHeader = rngHeaders.Find(what:="Username", After:=Cells(1, 1))
rngUsernameHeader.Offset(0, 1).EntireColumn.Insert
rngUsernameHeader.Offset(0, 1).Value = "role"
End Sub
Sub AddColumn
Dim cl as Range
For each cl in Range("1:1")
If cl = "username" Then
cl.EntireColumn.Insert Shift:= xlToRight
End If
cl.Offset(0, 1) = "role"
Next cl
End Sub
Untested code as not at my desktop
Something like this should work. The idea is that you locate the column and then you insert to the right. That is why you have the +1 in the TestMe. The function l_locate_value_col returns the column, where it has found the value. If you want, you may change the optional parameter l_row, depending on which row do you want to look for.
Option Explicit
Public Sub TestMe()
Dim lngColumn As Long
lngColumn = l_locate_value_col("Username", ActiveSheet)
Cells(1, lngColumn + 1).EntireColumn.Insert
End Sub
Public Function l_locate_value_col(target As String, _
ByRef target_sheet As Worksheet, _
Optional l_row As Long = 1)
Dim cell_to_find As Range
Dim r_local_range As Range
Dim my_cell As Range
Set r_local_range = target_sheet.Range(target_sheet.Cells(l_row, 1), target_sheet.Cells(l_row, Columns.Count))
For Each my_cell In r_local_range
If target = Trim(my_cell) Then
l_locate_value_col = my_cell.Column
Exit Function
End If
Next my_cell
l_locate_value_col = -1
End Function
You could name your range:
Sub Test()
Dim rngUsernameHeader As Range
'UserName is in column F at the moment.
Set rngUsernameHeader = Range("UserName")
Debug.Print rngUsernameHeader.Address 'Returns $F$1
ThisWorkbook.Worksheets("Sheet2").Range("E:E").Insert Shift:=xlToRight
Debug.Print rngUsernameHeader.Address 'Returns $G$1
End Sub
Edit:
Have rewritten so it inserts a column after your named column and returns that reference:
Sub Test()
Dim rngUsernameHeader As Range
Dim rngMyNewColumn As Range
Set rngUsernameHeader = Range("UserName")
rngUsernameHeader.Offset(, 1).Insert Shift:=xlToRight
'You'll need to check the named range doesn't exist first.
ThisWorkbook.Names.Add Name:="MyNewRange", _
RefersTo:="='" & rngUsernameHeader.Parent.Name & "'!" & _
rngUsernameHeader.Offset(, 1).Address
Set rngMyNewColumn = Range("MyNewRange")
MsgBox rngMyNewColumn.Address
End Sub
I need to find out the first cell and the last cell of a vertically merged cell..
Let's say I merge Cells B2 down to B50.
How can I get in VBA the start cell(=B2) and the end cell(=B50)?
Sub MergedAreaStartAndEnd()
Dim rng As Range
Dim rngStart As Range
Dim rngEnd As Range
Set rng = Range("B2")
If rng.MergeCells Then
Set rng = rng.MergeArea
Set rngStart = rng.Cells(1, 1)
Set rngEnd = rng.Cells(rng.Rows.Count, rng.Columns.Count)
MsgBox "First Cell " & rngStart.Address & vbNewLine & "Last Cell " & rngEnd.Address
Else
MsgBox "Not merged area"
End If
End Sub
Below macro goes through all sheets in a workbook and finds merged cells, unmerge them and put original value to all merged cells.
This is frequently needed for DB applications, so I wanted to share with you.
Sub BirlesenHucreleriAyirDegerleriGeriYaz()
Dim Hucre As Range
Dim Aralik
Dim icerik
Dim mySheet As Worksheet
For Each mySheet In Worksheets
mySheet.Activate
MsgBox mySheet.Name & “ yapılacak…”
For Each Hucre In mySheet.UsedRange
If Hucre.MergeCells Then
Hucre.Orientation = xlHorizontal
Aralik = Hucre.MergeArea.Address
icerik = Hucre
Hucre.MergeCells = False
Range(Aralik) = icerik
End If
Next
MsgBox mySheet.Name & " Bitti!!"
Next mySheet
End Sub
Suppose you merged B2 down to B50.
Then, start cell address will be:
MsgBox Range("B2").MergeArea.Cells(1, 1).Address
End cell address will be:
With Range("B2").MergeArea
MsgBox .Cells(.Rows.Count, .Columns.Count).Address
End With
You can put address of any cell of merged area in place of B2 in above code.
Well, assuming you know the address of one of the cells in the merged range, you could just select the offset from that range and get the row/column:
Sub GetMergedRows()
Range("A7").Select 'this assumes you know at least one cell in a merged range.
ActiveCell.Offset(-1, 0).Select
iStartRow = ActiveCell.Row + 1
Range("A7").Select
ActiveCell.Offset(1, 0).Select
iEndRow = ActiveCell.Row - 1
MsgBox iStartRow & ":" & iEndRow
End Sub
The code above will throw errors if the offset row cannot be selected (i.e. if the merged rows are A1 through whatever) so you will want to add error handling that tells the code if it can't offset up, the top rows must be 1 and if it can't go down, the bottom row must be 65,536. This code is also just one dimensional so you might want to add the x-axis as well.
If you want the cell references as strings, you can use something like this, where Location, StartCell, and EndCell are string variables.
Location = Selection.Address(False, False)
Colon = InStr(Location, ":")
If Colon <> 0 Then
StartCell = Left(Location, Colon - 1)
EndCell = Mid(Location, Colon + 1)
End If
If you want to set them as ranges, you could add this, where StartRange and EndRange are Range objects.
set StartRange = Range(StartCell)
set EndRange = Range (EndCell)
If you intend to loop through the merged cells, try this.
Sub LoopThroughMergedArea()
Dim rng As Range, c As Range
Set rng = [F5]
For Each c In rng.MergeArea
'Your code goes here
Debug.Print c.Address'<-Sample code
Next c
End Sub