I want to assign a value in column like serial number via click button. I already a make one code but its without button. I want to add button also.
Option Base 1
Function Check()
Dim i As Integer
Dim startCell As Range
Dim firstNonEmptyCell As Range
Set startCell = Range("G2")
If VBA.IsEmpty(startCell.Value) Then
MsgBox "No data in this column"
Else
Range("A2") = 1
Range("A2").Select
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
Step:=1, Stop:=400, Trend:=False
End If
End Function
Insert a Form button via Insert in the Developer Toolbar.
Paste the below code in a module and then right click on the button and click on assign Macro.
Select Button1_Click in the Assign Macro dialog box and you are done.
Code
Option Explicit
Sub Button1_Click()
Dim ws As Worksheet
Dim LRow As Long, i As Long
'~~> Change this to the relevant worsheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find Last Row in Col G which has data
LRow = .Range("G" & .Rows.Count).End(xlUp).Row
If LRow = 1 Then
MsgBox "No data in column G"
Else
For i = 2 To LRow
.Range("A" & i).Value = i - 1
Next i
End If
End With
End Sub
Related
I have this problem. Basically, program says it can't use the union range I've created for the .list property of my listbox. I'd like to trigger it when the userform initializes. The problem lies in the last line of code. Although when I try to .select UnionRange it won't work either. But if I do it without looping through the sheets it works ok.
Private Sub UserForm_Initialize()
Dim sh As Worksheet
Dim i As Long, RowNo As Long
Dim UnionRange As Range
'Loops through all sheets in workbook
For Each sh In Worksheets
'Stops looping when it reaches "LISTS" sheet
If sh.Name = "LISTS" Then
Exit For
End If
sh.Activate
RowNo = Range("e6").End(xlDown).Row
For i = RowNo To 1 Step -1
If Range("K" & i) = "TBD" Then
If UnionRange Is Nothing Then
Set UnionRange = Range("k" & i)
Else
Set UnionRange = Union(UnionRange, Range("k" & i))
End If
End If
Next
Next
'Error is next, should populate listbox list
lbTBDNAV.List = UnionRange.Value
End Sub
I have this problem. I've only been doing VBA for about a week. I have a workbook where I created a button that copies a certain range in a row and pastes it into a table on another sheet. My problem is this: do I need to create a module for each button, or can I somehow simplify the code to create the same buttons for each row on the first sheet?
Sub SelectRangea()
Sheets("Tournaments").Select
Range("B4:G4").Select
Application.CutCopyMode = False
Selection.Copy
With Sheets("Results")
lst = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & lst).PasteSpecial xlPasteColumnWidths
.Range("A" & lst).PasteSpecial xlPasteValues
End With
End Sub
You'll need to adjust the code accordingly but this will add a set of buttons for you as well as tell you the cell that the button was pressed from ...
Public Sub AddButtons()
Dim lngRow As Long, rngCell As Range, objButton As Shape
For lngRow = 1 To 10
Set rngCell = Sheet1.Cells(lngRow, 1)
Set objButton = Sheet1.Shapes.AddFormControl(xlButtonControl, rngCell.Left, rngCell.Top, rngCell.Width, rngCell.Height)
objButton.OnAction = "ButtonPushAction"
Next
End Sub
Public Sub ButtonPushAction()
Dim objCaller As Shape
Set objCaller = Sheet1.Shapes(Application.Caller)
MsgBox "Top Cell = " & objCaller.TopLeftCell.Address & vbCrLf & _
"Row = " & objCaller.TopLeftCell.Cells(1, 1).Row & vbCrLf & _
"Column = " & objCaller.TopLeftCell.Cells(1, 1).Column, vbInformation, "Button Push"
End Sub
Do I need to create a module for each button?
We only need to create one module containing the macros needed by the buttons and we can use the same macro for all the buttons.
Can I somehow simplify the code to create the same buttons for each row on the first sheet?
All the buttons should be identical, except their names. They can be copies of each other.
I assume we want to copy the row clicked. So I changed SelectRangea:
' Copy the code below to a standard module
Public Sub SelectRangea(RowNumber As Integer)
' Copy the row clicked
Sheets("Tournaments").Select
Range("B" & RowNumber & ":G" & RowNumber).Select
Application.CutCopyMode = False
Selection.Copy
' Paste the row clocked
With Sheets("Results")
lst = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & lst).PasteSpecial xlPasteColumnWidths
.Range("A" & lst).PasteSpecial xlPasteValues
End With
End Sub
And here is the click handler for the buttons:
' Copy the code below to a standard module
Public Sub MyButton_Click()
Dim Btn As Object
Dim RowNumber As Integer
'Set Btn = ActiveSheet.Buttons(Application.Caller) ' either this
Set Btn = ActiveSheet.Shapes(Application.Caller) ' or this
With Btn.TopLeftCell
RowNumber = .Row
End With
SelectRangea RowNumber
End Sub
Automatically create the buttons
We could create a macro that creates the buttons, if they don't exist, using Sheet.Shapes.AddShape and sets the .OnAction of them to MyButton_Click:
' Copy the code below to a standard module.
' Create buttons on a sheet.
' Sht : The sheet to create buttons on
' RowNumber : Create buttons from RowNumber and down.
' ColNumber : The column the button is created in.
' ColNumberSrc: The column used to determine the number of rows.
Public Sub AddButtons(Sht As WorkSheet,
RowNumber As Integer,
ColNumber As Integer,
ColNumberSrc As Integer)
Dim MyLeft As Double
Dim MyTop As Double
Dim Rng As Range
Dim Shp As Shape
Dim NumRows As Integer
NumRows = Sht.Range.Cells(Sht.Rows.Count, ColNumberSrc).End(xlUp).Row
If NumRows < RowNumber Then Exit Sub
For Idx = RowNumber To NumRows
Set Rng = Sht.Range.Cells(Idx, ColNumber)
MyLeft = Rng.Left
MyTop = Rng.Top
' We could let the size of the button's we create be the same size as the cell.
Set Shp = Sht.Shapes.AddShape(msoShapeRectangle, MyLeft, MyTop, 100, 22)
Shp.Name = "Btn" & Sht.Index & "_" & Idx
Shp.TextFrame.Characters.Text = "Clickme"
Shp.OnAction = "MyButton_Click"
Next Idx
End Sub
Don't use buttons
We could remove the buttons and use double-click instead. This will copy the double-clicked row:
' Copy the three lines to the corresponding function in your sheet module.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim RowNumber As Integer
RowNumber = Target.Row
SelectRangea RowNumber
End Sub
Don't confuse the user
We should avoid the use of Copy and Select, as it can worsen the user experience. We should only use them when the user expects us to use them. Refactor the code to avoid using them:
' Copy the code below to a standard module
Public Sub SelectRangea(ByVal RowNumber As Integer)
Dim Sht As WorkSheet
Dim Rng As Range
Dim Dat As Variant
' Copy the row clicked
Set Sht = Sheets("Tournaments")
Set Rng = Sht.Range("B" & RowNumber & ":G" & RowNumber)
Dat = Rng
' Paste the row
Set Sht = Sheets("Results")
RowNumber = Sht.Range("A" & Sht.Rows.Count).End(xlUp).Row + 1
Set Rng = Sht.Range("B" & RowNumber & ":G" & RowNumber)
Rng = Dat
' Fix column widths
Sht.UsedRange.Columns.AutoFit
End Sub
See also
how to add a shape at a specific cell
how to get the row number of the button clicked.
how to get the row of the cell clicked
NB
I don't have access to an office environment, so I can't test the code at the moment.
I think we can set an option for a shape so it stays in it's cell when cells are resized, added or deleted.
I'm trying to make a UserForm with comboboxes and textboxes. I have two combobox that are working together. In the first one you choose the right sheet and in the second you choose the right column in the selected sheet.
My problem is that even though my code is working, the second combobox doesn't use the moving information from the first one. It always displays the columns from the first sheet whatever my choice. So how do I get the data from the first one to use it in the second one?
Here's my code:
Private Sub UserForm_Initialize()
Dim I As Long
Me.ComboBox1.Clear
For I = 7 To Sheets.Count
Me.ComboBox1.AddItem Sheets(I).Name
Next
Me.ComboBox1.Value = ActiveSheet.Name
Me.ComboBox2.Clear
Dim j As Integer
Dim puits As String
j = 3
Do While Worksheets(ComboBox1.Text).Cells(1, j).Value <> ""
Me.ComboBox2.AddItem Worksheets(Me.ComboBox1.Text).Cells(1, j).Value
j = j + 3
Loop
End Sub```
EDIT
[USF is to automate the change of the selected cell in this screenshort, same tables on different sheets][1]
[1]: https://i.stack.imgur.com/7bbQG.png
You need to use the Combobox_Change-Event. This Example shows what I mean:
Private Sub ComboBox1_Change()
Dim ws As Worksheet
Dim lCol As Long, i As Long
Set ws = ThisWorkbook.Worksheets(UserForm1.ComboBox1.Value)
lCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For i = 1 To lCol
UserForm1.ComboBox2.AddItem ws.Cells(1, i).Value
Next
End Sub
Private Sub UserForm_Initialize()
Me.ComboBox1.Clear
Me.ComboBox2.Clear
Dim ws As Worksheet
Dim i As Long
i = 1
For Each ws In ThisWorkbook.Worksheets
Me.ComboBox1.AddItem ws.Name
i = i + 1
Next ws
End Sub
When I select the Sheet, I change the first Combobox, which triggers the Change-Event. And I then populate the second Combobox according to the selected sheet.
EDIT
You could insert a CommandButton and use code like the following:
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim rng As Range
Set ws = ThisWorkbook.Worksheets(UserForm1.ComboBox1.Value)
Set rng = ws.Range(UserForm1.ComboBox2.Value)
rng.Value = "Your Date"
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 have some code that almost works exactly as I'd like, below. At the moment, I have two sheets, one for Y-department, and one for X-department. I'd like a button to pass a range of cells (A:L) from the Y-department sheet to the X-department sheet. I don't want to paste the entire row because there are formulae from M-W in the X-department sheet, which get overwritten when I do that.
At the moment, this almost works. But it only lets me pass one row at a time. Is it possible to edit this code so that I can select more than one row at a time and it will cut and paste (only cells A:L of) all of those rows onto the X-department sheet?
Thanks in advance!
Sub Pass_to_Xdepartment()
If MsgBox("Do you want to pass the selected tours to Xdepartment?", vbYesNo, "Pass to XDepartment") = vbNo Then Exit Sub
For Each WSheet In ActiveWorkbook.Worksheets
If WSheet.AutoFilterMode Then
If WSheet.FilterMode Then
WSheet.ShowAllData
End If
End If
For Each DTable In WSheet.ListObjects
If DTable.ShowAutoFilter Then
DTable.Range.AutoFilter
DTable.Range.AutoFilter
End If
Next DTable
Next WSheet
'Declare variables
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim lastRow As Long
'Set variables
Set sht1 = Sheets("YDepartment")
Set sht2 = Sheets("XDepartment")
'Select Entire Row
Range("A" & ActiveCell.Row & ":L" & ActiveCell.Row).Select
'Move row to destination sheet & Delete source row
lastRow = sht2.Range("A" & sht2.Rows.Count).End(xlUp).Row
With Selection
.Copy Destination:=sht2.Range("A" & lastRow + 1)
.EntireRow.Delete
End With
End Sub
Also, out of interest, do you know if there's a way to set up this button so that it sends an email at the same time as passing over the data to notify X-department when rows have been passed over to their sheet? This is a secondary concern though.
Some suggestions, some "must haves":
Avoid using Select in Excel VBA
Obviously Range("A" & ActiveCell.Row & ":L" & ActiveCell.Row) is only one row because ActiveCell is a single cell not a range of cells. If you want to get columns A to L of the selected range use …
Selection.EntireRow.Resize(ColumnSize:=12) '= first 12 columns of selection
All your Range and Cells should be specified with a worksheet like sht1.Range.
Use meaningful variable names eg replace sht1 with wsSource and sht2 with wsDestination which makes your code much easier to understand.
Don't test your message box like If MsgBox(…) = vbNo Then instead test for If Not MsgBox(…) = vbYes. Otherwise pressing the X in the right top corner of the window has the same effect as pressing the Yes button.
Make sure you really mean ActiveWorkbook (= the one that has the focus / is on top) and not ThisWorkbook (= the one this code is running in).
I recommend to activate Option Explicit: In the VBA editor go to Tools › Options › Require Variable Declaration and declare all your variables properly.
So you end up with something like:
Option Explicit
Public Sub Pass_to_Xdepartment()
If Not MsgBox("Do you want to pass the selected tours to Xdepartment?", vbYesNo, "Pass to XDepartment") = vbYes Then
Exit Sub
End If
Dim ws As Worksheet, DTable As ListObject
For Each ws In ThisWorkbook.Worksheets
If ws.AutoFilterMode Then
If ws.FilterMode Then
ws.ShowAllData
End If
End If
For Each DTable In ws.ListObjects
If DTable.ShowAutoFilter Then
DTable.Range.AutoFilter
DTable.Range.AutoFilter
End If
Next DTable
Next ws
Dim wsSrc As Worksheet
Set wsSrc = ThisWorkbook.Worksheets("YDepartment")
Dim wsDest As Worksheet
Set wsDest = ThisWorkbook.Worksheets("XDepartment")
Dim LastRow As Long
LastRow = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).Row
'Move row to destination sheet & Delete source row
With Selection.EntireRow.Resize(ColumnSize:=12) '= A:L of the selected rows
.Copy Destination:=wsDest.Cells(LastRow + 1, "A")
.EntireRow.Delete
End With
End Sub
Edit according to comments (write date):
Since you delete the copied rows anyway you can first write the date to column M
Intersect(Selection.EntireRow, Selection.Parent.Columns("M")).Value = Date
And then copy A:M instead of A:L
With Intersect(Selection.EntireRow, Selection.Parent.Range("A:M")) '= A:M of the selected rows
.Copy Destination:=wsDest.Cells(LastRow + 1, "A")
.EntireRow.Delete
End With
I have a macro that copies row by row of a selected range and pastes it on the next one. Maybe it'll help out.
Also, if you know the number of rows you're working with, you can always do
Range(Ax:Lx).Select
If not, this might do the trick:
Dim i As Integer
i = 2 //1 if first row isn't headers.
Do While sht1.Range("A" & i).Value <> Empty
sht1.Range("A" & i & "L" & i).Select
Selection.Copy
sht2.Range("A" & lastrow +1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
i = i + 1
Loop
Let me know if it helps or it needs adjustment.