I'm just starting with VBA and i'm stuck on a userform.
I am looking for a method that will allow me to click a command button and the text that is on that button will then appear in the last blank cell in a certain column. (for exemple in A2)
Private Sub CommandButton1_Click()
If MsgBox("Please confirm your choice ?", vbYesNo, "Confirmation") = vbYes Then
Worksheets("Sheet1").Select
ligne = Sheets("Sheet1").Range("A456541").End(xlUp).Row + 1
End If
Worksheets("Sheet1").Activate
Range("A2").Select Range("A2").Value = "Multiproject" & vbNewLine & vbNewLine
End Sub
After pen comment, my code looks like this :
Private Sub Multiproject_Click()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim NextFreeCell As Range ' find next free cell in column A
Set NextFreeCell = ws.Cells(ws.Rows.Count, "A").End(xlUp)
If MsgBox("Please confirm your choice?", vbYesNo, "Confirmation") = vbYes Then
NextFreeCell.Value = "Multiproject" & vbNewLine & vbNewLine
End If
Unload FrmCustomMsgbo
End Sub
[1]: https://i.stack.imgur.com/4rGKP.png
Just find the next free cell and write the value there:
Option Explicit
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim NextFreeCell As Range ' find next free cell in column A
Set NextFreeCell = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(RowOffset:=1)
If MsgBox("Please confirm your choice?", vbYesNo, "Confirmation") = vbYes Then
NextFreeCell.Value = "Multiproject" & vbNewLine & vbNewLine
End If
End Sub
You might benefit from reading
How to avoid using Select in Excel VBA.
And I highly recommend to give your command button a useful name CommandButton1 is not useful at all.
Related
I'm stuck trying to delete a row in a table after copying and pasting it to another Workbook table. It worked when I was activating workbooks and sheets but now has stopped. Can this be done the way I have the code now? Any help is greatly appreciated. I have been trying to fix this for two days now..
Sub MoveOrdertoDelivery()
'
' Move_Order Macro
' Move the next line on the Delivery Log for the day
'
'*************************************************************************
' New Code for MoveLinetoDeliverySchedule
'*************************************************************************
Dim copyrng As Range
Dim rngOld As Range
Dim msgRes As VbMsgBoxResult
Dim checkcellrange As Range
Dim strFileDir As String
' new to use the better code****DELETE AFTER IT WORKS
Dim destinationSheetName As String
Dim originatingWorkbookName As String
Dim originatingWorkbook As Workbook
Dim destinationWorkbook As Workbook
Dim originatingSheetName As String
Dim destinationFileName As String
Dim originatingTableName As String
Dim destinationTableName As String
strFileDir = ThisWorkbook.Path
originatingWorkbookName = ActiveWorkbook.Name
originatingSheetName = ActiveSheet.Name
destinationFileName = strFileDir & "\Door Delivery Schedule.xlsm"
Set checkcellrange = Range("A1:ZZ3")
Set rngOld = ActiveCell
Set originatingWorkbook = Workbooks.Open(strFileDir & "\" & originatingWorkbookName)
ActiveSheet.Cells(ActiveCell.Row, 1).Select
Set copyrng = Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 11))
copyrng.Select
If Intersect(checkcellrange, copyrng) Is Nothing Then
originatingTableName = ActiveCell.ListObject.Name
Else
msgRes = MsgBox("Please select a table Row!", vbOKCancel)
Exit Sub
End If
If Intersect(checkcellrange, rngOld) Is Nothing Then
If Not allBlank(ThisWorkbook.Sheets(originatingSheetName).Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 11))) Then
msgRes = MsgBox("Proceed?", vbOKCancel, "You are about to Move this row to the Door Delivery Schedule.")
If msgRes = vbOK Then
Selection.Copy
On Error Resume Next
tablerow = Selection.Row - Selection.ListObject.Range.Row
If Err.Number = 91 Then
MsgBox "Please select a line with data in it!"
Exit Sub
End If
'originatingWorkbook.Sheets(originatingSheetName).Range(ListObjects(originatingTableName).ListRows(tablerow)).Copy
'originatingWorkbook.Sheets(originatingSheetName).Range(copyrng).Copy
Set destinationWorkbook = Workbooks.Open(destinationFileName)
destinationWorkbook.Sheets("Orders For Delivery").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
destinationWorkbook.Save
destinationWorkbook.Close
'originatingWorkbook.Sheets(originatingSheetName).Selection.Delete Shift:=
Windows("Production Schedule Main.xlsm").Activate
Sheets("Completed Orders").Activate
copyrng.Select
originatingWorkbook.Sheets(originatingSheetName).Selection.ListObject.ListRows(tablerow).Delete
Selection.Delete Shift:=x1Up
Exit Sub
Else
End If
Else
MsgBox ("Please select a row with data in it.")
End If
Else
MsgBox ("Please select a legal row in the field.")
End If
End Sub
i am trying to insert data into different tabs of an excel file via a combo box in VBA. I have got the tabs named ByteDance and Zapp. What I want is that if I select ByteDance in the combo box of the userform, the data that I insert will be in the ByteDance tab. The data however does not come from a database and needs to be filled in manually via data entry.
I have got a combo box named CompanyName and have managed to include the list of company names as shown. The list of company names is in the tab called "Names". As for the userform, it is named as "insertfundinground"
Private Sub UserForm_Initialize()
'Combobox listing
Dim lastrow As Long
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("Names")
lastrow = ws.Range("A2").End(xlDown).Row
CompanyName.List = ws.Range("A2:A" & lastrow).Value
End Sub
My userform looks something like this
Userform
So if I were to select ByteDance, the data that needs to be filled in manually will go to the ByteDance tab of my excel file. However, when I tried to do so, the data was not filled into the ByteDance tab although there were no error prompts. My code is as follows
Sub EnterInput()
Dim lastrow As Long
Dim wb As ThisWorkbook
Dim ws As Worksheet
Select Case CompanyName
Case "ByteDance"
lastrow = wb.Sheets("ByteDance").Range("A1").End(xlDown).Row
wb.Sheets("ByteDance").Range("A" & lastrow + 1) = insertfundinground.DateInput.Value
wb.Sheets("ByteDance").Range("B" & lastrow + 1) = insertfundinground.DealTypeInput.Value
wb.Sheets("ByteDance").Range("C" & lastrow + 1) = insertfundinground.RaisedInput.Value
wb.Sheets("ByteDance").Range("D" & lastrow + 1) = insertfundinground.PostMoneyInput.Value
wb.Sheets("ByteDance").Range("E" & lastrow + 1) = insertfundinground.InvestorsInput.Value
Case "Zapp"
lastrow = wb.Sheets("Zapp").Range("A1").End(xlDown).Row
wb.Sheets("Zapp").Range("A" & lastrow + 1) = insertfundinground.DateInput.Value
wb.Sheets("Zapp").Range("B" & lastrow + 1) = insertfundinground.DealTypeInput.Value
wb.Sheets("Zapp").Range("C" & lastrow + 1) = insertfundinground.RaisedInput.Value
wb.Sheets("Zapp").Range("D" & lastrow + 1) = insertfundinground.PostMoneyInput.Value
wb.Sheets("Zapp").Range("E" & lastrow + 1) = insertfundinground.InvestorsInput.Value
End Select
End Sub
Private Sub Enter_Click()
Dim msgValue As VbMsgBoxResult
msgValue = MsgBox("Do you want to save the data?", vbYesNo + vbInformation, "Confirmation")
If msgValue = vbNo Then
Exit Sub
Else
Call EnterInput
End If
End Sub
Any help is appreciated. Thanks!
Try changing Dim wb As ThisWorkbook to
Dim wb as Workbook
Set wb = ThisWorkbook
or alternative using With
Option Explict
Sub EnterInput()
Dim ar, lastrow As Long, i As Long
ar = Array("Date", "DealType", "Raised", "PostMoney", "Investors")
Select Case CompanyName
Case "ByteDance", "Zapp"
With ThisWorkbook.Sheets(CStr(CompanyName))
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
For i = 0 To UBound(ar)
.Range("A" & lastrow).Offset(, i) = Me.Controls(ar(i) & "Input").Value
Next
End With
Case Else
MsgBox "'" & CompanyName & "' not valid", vbExclamation
End Select
End Sub
I have developed a code to copy a sheet and rename the sheet name with the value given in the insert box and then copy the same value in the summary sheet and select the last cell and paste the value but I want to create the hyperlink so that if i click on that value it will take me to that sheet.
I am stuck at the giving the proper subaddress.
Private Sub CommandButton1_Click()
Dim sName As String
Dim oRng As Range
sName = InputBox("New Shipment", "New AWB Number", "Enter the AWB Number")
If sName <> "" Then
ThisWorkbook.Sheets("Templete").Copy Before:=Sheets(3)
ActiveSheet.Name = sName
MsgBox "New AWB Number Tracking Added"
Else
MsgBox "Failed"
End If
Sheets("Summary").Select
Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Activate
ActiveCell.Value = sName
'ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
"'Sheet(3)'!A1"
End Sub
When I run this I am getting an error:
"Reference isn't valid"
Please help.
You can always run into issues when using Select and Activate but I suspect your main issue was your hyperlink sub address. You where trying to set it to 'Sheet(3)'!A1" which excel won't recognise as it is the sheet position (which VBA recognises) rather than the sheet name. Have a look at the below
Private Sub CommandButton1_Click()
Dim sName As String
Dim oRng As Range
Dim nWs As Worksheet
sName = InputBox("New Shipment", "New AWB Number", "Enter the AWB Number")
If sName <> "" Then
With ThisWorkbook
.Sheets("Templete").Copy Before:=.Sheets(3)
Set nWs = .Sheets(3)
End With
nWs.Name = sName
With Sheets("Summary")
With .Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
.Value2 = sName
.Parent.Hyperlinks.Add Anchor:=.Cells, Address:="", SubAddress:= _
"'" & nWs.Name & "'!A1"
End With
End With
MsgBox "New AWB Number Tracking Added"
Else
MsgBox "Failed"
End If
End Sub
You should probably also add to this a check to test against existing sheets for duplicate or invalid names entered by the user.
I have done 2 separate prog till now.
One displays a message box before closing a workbook:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim answer As String
Dim question As String
question = "Display all the sheets which are Unprotected"
answer = MsgBox(question, vbYesNo)
If answer = vbNo Then
MsgBox "complete everything and then close"
Cancel = True
Exit Sub
Else
ThisWorkbook.Save
End If
End Sub
Another displays in a new sheet "Unprotected", list of all the unprotected sheets.
Sub UnprotectSheet()
Dim ws As Worksheet, a As Range
ActiveWorkbook.Worksheets.Add.Name = "Unprotected"
For Each ws In ActiveWorkbook.Worksheets
If ws.ProtectContents = False And ws.Name <> "Unprotected" Then
CNT = Sheets("Unprotected").Cells(Sheets("Unprotected").Rows.Count, "A").End(xlUp).Row
Sheets("Unprotected").Cells(CNT + 1, "A") = ws.Name
End If
Next
End Sub
I want a Message box to appear if I try to close the worksheet and if any sheet is unprotected, the message box displays the names of the unprotected sheets. I am facing problem in combining the above 2 codes.
I am not a VBA expert and I am trying it but unable to solve it.
Something like this can show you a list of the unprotected sheets. However, it's probably better to just use VBA to force their protection, rather than prompting the user to do it (unless they need to provide a password for protection status).
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim answer As String
Dim question As String
Dim unprotected as String
unprotected = GetUnprotectedSheets(ThisWorkbook)
If unprotected <> vbNullString Then
MsgBox "Please protected the following worksheets before closing" & vbCRLF & unprotected
Cancel = True
Exit Sub
Else
ThisWorkbook.Save
End If
End Sub
Function GetUnprotectedSheets(wb as Workbook)
'Custom function to return a string of sheet names
' which are unprotected
Dim ret as String
Dim ws as Worksheet
For each ws in wb.Worksheets
If Not ws.ProtectContents Then
ret = IIF(ret = "", ws.Name, ret & vbCRLF & ws.Name)
End If
Next
GetUnprotectedSheets = ret
End Function
You can call a procedure like this to ensure all sheets are protected:
Sub ProtectAllSheets(wb as Workbook)
Dim ws as Worksheet
For each ws in wb.Worksheets
If Not ws.ProtectContents Then ws.Protect
Next
End Sub
Just add a counter to your second script:
Sub UnprotectSheet()
Dim ws As Worksheet, a As Range
Dim iCounter As Integer, strMessage As String 'Adding a counter variable & string
'ActiveWorkbook.Worksheets.Add.Name = "Unprotected"
iCounter = 0 'Initialize it
strMessage = "" 'Initialize empty string for the message box
For Each ws In ActiveWorkbook.Worksheets
If ws.ProtectContents = False Then
iCounter = iCounter + 1 'Keeping track of any unprotected sheet
' CNT = Sheets("Unprotected").Cells(Sheets("Unprotected").Rows.Count, "A").End(xlUp).Row
' Sheets("Unprotected").Cells(CNT + 1, "A") = ws.Name
strMessage = strMessage & ws.Name & " "
End If
Next
' Here you can do your msgbox or any other action if unprotected sheet detected
If iCounter > 0 Then
MsgBox ("These sheets are unprotected: " & strMessage)
End If
End Sub
EDIT:
To enclose that within a button click: add an activeX button to your form, then:
Private Sub CommandButton1_Click()
'E.g. make the sub a commmandbutton_click() event
End Sub
Actually, when you add the button to your form, if you right-click on it you have the option "View code" - this will create an associated Commandbutton_click like I showed above.
I am trying to develop a quick and easy project management tracker. I currently am using a inputbox to get the name of the project (PrjName) to add. The code will then copy the template and paste it into the "Projects" worksheet at the next available COLUMN (+1 for extra space between projects). I then want to add the PrjName as a list of projects on the dashboard worksheet but adding it as a hyperlink that will link to the appropriate column where the project has been pasted on the "Projects" worksheet. I have figured out how to copy/paste the way I want it to look, but I don't know how to even start creating a reference for the hyperlink. I thought I could possibly do this by using the project name to create a named range that somehow references the information pasted and then reference that name for the hyperlink but am not sure how to accomplish this. Here is what I have for so far but it is probably a long way from correct.
Private Sub CommandButton1_Click()
Dim FirstBlankCol As Range
PrjName = InputBox("Enter the name of the project", "User Input Required")
If PrjName = "" Then Exit Sub
'Find First Blank Cell to add new Project on Summary Worksheet
Set FirstBlankCol = Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
Worksheets("Summary").Hyperlinks.Add Anchor:=FirstBlankCol, Address:="", SubAddress:= _
"PrjName", TextToDisplay:=PrjName
With Sheets("Projects")
Select Case Sheets("Projects").Range("A1") = ""
Case True 'paste in Col A if A1 is empty
Sheets("Template").Range("A1:F5").Copy
Sheets("Projects").Range("A1") _
.PasteSpecial Paste:=xlPasteColumnWidths
Sheets("Projects").Range("A1") _
.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
Case False 'paste in next col
Sheets("Template").Range("A1:F5").Copy
Sheets("Projects").Range("IV1").End(xlToLeft).Offset(0, 6) _
.PasteSpecial Paste:=xlPasteColumnWidths
Sheets("Projects").Range("IV1").End(xlToLeft).Offset(0, 6) _
.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
End Select
Application.CutCopyMode = False
End With
End Sub
Give this a try:
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim wsPrj As Worksheet
Dim wsTmp As Worksheet
Dim rngDest As Range
Dim strProjectName As String
strProjectName = InputBox("Enter the name of the project", "User Input Required")
If Len(Trim(strProjectName)) = 0 Then Exit Sub 'Pressed cancel
Set ws = ActiveSheet
Set wsPrj = Sheets("Projects")
Set wsTmp = Sheets("Template")
Application.ScreenUpdating = False
If Len(wsPrj.Range("A1").Text) = 0 Then Set rngDest = wsPrj.Range("A1") Else Set rngDest = wsPrj.Cells(1, Columns.Count).End(xlToLeft).Offset(, 6)
wsTmp.Range("A1:F5").Copy
rngDest.PasteSpecial xlPasteAllUsingSourceTheme
rngDest.PasteSpecial xlPasteColumnWidths
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Replace(strProjectName, " ", "_"), "='" & wsPrj.Name & "'!" & rngDest.Address
ws.Hyperlinks.Add ws.Cells(Rows.Count, "B").End(xlUp).Offset(1), "", Replace(strProjectName, " ", "_"), , strProjectName
Application.ScreenUpdating = True
End Sub