i am getting object required run time error in below code at line , i checked sheet names they are correct but still showing same error Sheet1.Range("A1").Value = Date & " " & Time
Private Sub CommandButton1_Click()
Dim username As String
Dim password As String
username = TextBox1.Text
password = TextBox2.Text
Dim info
info = IsWorkBookOpen("D:\TMS_Project\username-password.xlsx")
If info = False Then
Workbooks.Open ("D:\TMS_Project\username-password.xlsx")
End If
Dim x As Integer
x = 2
Do While Cells(x, 1).Value <> ""
If Cells(x, 1).Value = username And Cells(x, 2).Value = password Then
MsgBox "Welcome!"
Sheet1.Range("A1").Value = Date & " " & Time
Selection.NumberFormat = "m/d/yyyy h:mm AM/PM"
UserForm1.Hide
ActiveWorkbook.Close True
End
Else
x = x + 1
End If
Loop
MsgBox "Please check your username or password!"
ActiveWorkbook.Close True
TextBox1.Text = ""
TextBox2.Text = ""
TextBox1.SetFocus
End Sub
When you use Sheet1.Range("A1").Value, Sheet1 is actually the Worksheet.CodeName property, read here on MSDN.
While I think you meant to use the worksheet, which name is "Sheet1", then you need to use Worksheets("Sheet1").Range("A1").Value.
If you would have defined and set your Worksheet object, you would have been able to track it.
I am using the piece of code below, to verify that no one has changed my sheet's name (or deleted it).
Option Explicit
' list of worksheet names inside Workbook - easy to modify here later
Const ShtName As String = "Sheet1"
'====================================================================
Sub VerifySheetObject()
Dim Sht As Worksheet
On Error Resume Next
Set Sht = ThisWorkbook.Worksheets(ShtName)
On Error GoTo 0
If Sht Is Nothing Then ' in case someone renamed the Sheet (or it doesn't exist)
MsgBox "Sheet has been renamed, it should be " & Chr(34) & ShtName & Chr(34), vbCritical
Exit Sub
End If
' your line here
Sht.Range("A1").Value = Date & " " & Time
End Sub
To use Variables for your Sheets use:
Dim sht as Worksheet
Set sht = Worksheets("Name")
If you are refering a lot to worksheets its a must to use, but also makes it much easier to change later on.
Related
I am trying to create code that will delete all sheets in active workbook if name contains part text from input. So far nothing seems working and I have no clue why.
I am using this code:
Private Sub CommandButton28_Click()
Dim shName As String
Dim xName As String
Dim xWs As Worksheet
Dim cnt As Integer
shName = Application.InputBox("Enter the specific text:", "Delete sheets", _
ThisWorkbook.ActiveSheet.Name, , , , , 2)
If shName = "" Then Exit Sub
xName = "*" & shName & "*"
' MsgBox xName
Application.DisplayAlerts = False
cnt = 0
For Each xWs In ThisWorkbook.Sheets
If xWs.Name Like xName Then
xWs.Delete
cnt = cnt + 1
End If
Next xWs
Application.DisplayAlerts = True
MsgBox "Have deleted " & cnt & " worksheets", vbInformation, "Sheets removed"
End Sub
But when I enter specific text (no spaces before or after) it doesn't work. Any ideas how to fix it?
Here is data from sheet where I tested it: Sheets names
And here is the result of macro: Result of macro
Like is case sensitive. Try making the following changes to your code (please see comments starting with '****)
Private Sub CommandButton28_Click()
Dim shName As String
Dim xName As String
Dim xWs As Worksheet
Dim cnt As Integer
shName = Application.InputBox("Enter the specific text:", "Delete sheets", _
ThisWorkbook.ActiveSheet.Name, , , , , 2)
If shName = "" Then Exit Sub
'**** use LCase() here
xName = "*" & LCase(shName) & "*"
' MsgBox xName
Application.DisplayAlerts = False
cnt = 0
For Each xWs In ThisWorkbook.Sheets
'**** Use LCase() here
If LCase(xWs.Name) Like xName Then
xWs.Delete
'MsgBox xName
cnt = cnt + 1
End If
Next xWs
Application.DisplayAlerts = True
MsgBox "Have deleted " & cnt & " worksheets", vbInformation, "Sheets removed"
End Sub
Please also note that your code doesn't check if the sheet to be deleted is the only sheet in the workbook (will raise an error). Furthermore, if the user sends * (intentionally or by mistake) your code will delete all sheets except one. This is dangerous, so please think about your code strategy and act accordingly. An idea is to save a backup copy before deleting the sheets
Sub BackupWorkbook(wb As Workbook)
wb.SaveCopyAs "FULL_BACKUP_PATH" & Format(Now, "yyyymmddhhmmss") & ThisWorkbook.Name
End Sub
The problem with like is it is expecting one char when using *Name*.
You can use InStr to find your string:
If InStr(1, xWs.Name, shName ) > 0 Then
xWs.Delete
cnt = cnt + 1
End If
You must use InStr instead of 'like' and loop from last sheet to first sheet
For i = ThisWorkbook.Sheets.Count To 1 Step -1
Set xWs = ThisWorkbook.Sheets(i)
If InStr(xWs.Name, shName ) > 0 Then
xWs.Delete
cnt = cnt + 1
End If
Next i
I have an Excel work book which is acting as a database and a UserForm which acts as a UI. Both are in different workbooks.
I want to populate the UserForm with data from Excel workbook .
Private Sub CommandButton4_Click()
Dim n As Long, i As Long
n = 0
Dim mydata1 As Workbook
Set mydata1 = Workbooks.Open("\\NTSYDFSP150\Shared\fmd\credit\LEM_Reports\SV References\SV Entry Form Input.xlsx")
mydata1.Worksheets("sheet1").Activate
mydata1.Worksheets("sheet1").Range("A1").Select
n = Worksheets("sheet1").Range("a1").CurrentRegion.Rows.Count
For i = 2 To n
If Trim(Sheet1.Cells(i, 1)) <> Trim(UserForm1.TextBox157.Text) And i = n Then
MsgBox ("Name not found")
End If
If Trim(Sheet1.Cells(i, 1)) = Trim(UserForm1.TextBox157.Text) Then
UserForm1.TextBox1.Text = Sheet1.Cells(i, 1)
Exit For
End If
Next i
mydata1.Save
mydata1.Close
MsgBox "Data searched successfully", 0, vbNullString
End Sub
Issue :
When I run the code am not able to retrieve data from workbook Excel database.
Sheet1.Cells(i, 1): - This field still refers to Shee1 from User form work book while it should be referring to work book at shared drive location since I had activated and opened that .
Note: n is calculated correctly.
I cleaned up your code and qualified the ranges where necessary. Not qualifying the ranges is most likely the error here. Example: Worksheets("sheet1").Range("a1"). ... needs to be mydata1.Worksheets("sheet1").Range("a1"). .... Try the following code:
Private Sub CommandButton4_Click()
Dim n As Long, i As Long
n = 0
Dim mydata1 As Workbook
Set mydata1 = Workbooks.Open("\\NTSYDFSP150\Shared\fmd\credit\LEM_Reports\SV References\SV Entry Form Input.xlsx")
n = mydata1.Worksheets("sheet1").Range("a1").CurrentRegion.Rows.Count
For i = 2 To n
If Trim(mydata1.Sheet1.Cells(i, 1)) <> Trim(UserForm1.TextBox157.Text) And i = n Then
MsgBox ("Name not found")
End If
If Trim(mydata1.Sheet1.Cells(i, 1)) = Trim(UserForm1.TextBox157.Text) Then
UserForm1.TextBox1.Text = mydata1.Sheet1.Cells(i, 1)
Exit For
End If
Next i
mydata1.Save
mydata1.Close
MsgBox "Data searched successfully", 0, vbNullString
End Sub
Note that activating the workbook and .Selecting a Range is not necessary in this case (so I deleted it) and should be avoided in general (see comment above for additional advice).
This is just a suggested way to prevent opening another workbook:
Private Sub CommandButton4_Click()
Dim wbPath As String: wbPath = "\\NTSYDFSP150\Shared\fmd\credit\LEM_Reports\SV References\"
Dim wbName As String: wbName = "SV Entry Form Input.xlsx"
Dim wsName As String: wsName = "sheet1"
Dim arrList As Object: Set arrList = CreateObject("System.Collections.ArrayList")
Dim lr As Long, x As Long
'Get the last row from A column, notice we need R1C1 notation for Excel4Macro
lr = ExecuteExcel4Macro("MATCH(""zzz"",'" & wbPath & "[" & wbName & "]" & wsName & "'!C1)")
'Let's use an ArrayList to get our validation list
For x = 2 To lr
arrList.Add Trim(ExecuteExcel4Macro("'" & wbPath & "[" & wbName & "]" & wsName & "'!R" & x & "C1"))
Next x
'Check if ArrayList contains your lookup value
If arrList.Contains(Trim(UserForm1.TextBox157.Text)) Then
UserForm1.TextBox1.Text = UserForm1.TextBox157.Text
Else
MsgBox ("Name not found")
End If
MsgBox "Data searched successfully"
End Sub
I have a VBA code that copies a template sheet and renames it.
I have the new name saved as a public string:
"My_Tamplate" is the sheet I copy from. "PublicStringName" is the public string variable I use to rename it to.
I also use the "PublicStringName" in other places in the form, this is why I needed it as a string.
Sheets("My_Tamplate").Copy After:=Worksheets(Sheets.Count)
ActiveSheet.name = PublicStringName
Next when I need to write the data I collected using a form, I want to write it to the newly created sheet.
Next I open a new form, collect data from the user to several variables.
Now I want to write the data into the newly created sheet (now named "PublicStringName"). If I declare WS as worksheet, it will not accept "PublicStringName" as it is a string (I think).
I do not know what sheet number it will be so I cannot call it by (sheet1) for example.
I don't know how to upload my example excel, so:
The Excel has 2 sheets named: Data (sheet2) and Project_Template (Sheet1). In sheet2 C3 I have =MAX(B:B).
I have 1 form (UserForm1), it has a multi page object.
In page 1 I have a text box txtProjectName and a button cmdCreateProject.
In page 2 I have 5 text boxes, named: txtData1 to txtData5 and an Update button btnUpdate.
I tried PeterT's solution (here in the code). Attaching the problematic code here:
Public ProjectName
Private Sub btnUpdate_Click()
Dim WS As Worksheet
Dim Addme As Range
Set WS = ThisWorksheet.Sheets(ProjectName)
Set Addme = WS.Cells(Rows.Count, 3).End(xlUp)
With WS
Addme.Offset(0, 1).Value = Me.txtData1
Addme.Offset(0, 2).Value = Me.txtData2
Addme.Offset(0, 3).Value = Me.txtData3
Addme.Offset(0, 4).Value = Me.txtData4
Addme.Offset(0, 5).Value = Me.txtData5
End With
MsgBox "Contact for Project:" & " " & ProjectName & ", " & "was successfully
added"
End Sub
Private Sub cmdCreateProject_Click()
Dim path As String
Dim mydir As String
Dim DataSh As Worksheet
Set DataSh = Sheet2
ProjectName = ""
'error handler
On Error GoTo errHandler:
ProjectName = Me.txtProjectName.Value
If Me.txtProjectName.Value = "" Then
MsgBox "Please enter a Project Name", vbOKOnly, "Project Name Error"
Exit Sub
End If
mydir = ThisWorkbook.path & "\" & ProjectName
If Dir(mydir, vbDirectory) = "" Then
MkDir mydir
'Copy tamplate sheet to for new Project
Sheets("Project_Template").Copy After:=Worksheets(Sheets.Count)
ActiveSheet.Name = ProjectName
Else
MsgBox "Directory already exsists"
Me.txtProjectName.Value = ""
Me.txtProjectName.SetFocus
ProjectName = ""
Exit Sub
End If
Set Addme = DataSh.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
DataSh.Activate
DataSh.Select
With DataSh
'add the unique reference ID then all other values
Addme.Offset(0, -1) = DataSh.Range("C3").Value + 1
Addme.Value = Me.txtProjectName
End With
Me.MultiPage1.Pages(1).Enabled = True
Me.MultiPage1.Pages(1).Visible = True
Me.MultiPage1.Pages(0).Enabled = Fals
Me.MultiPage1.Pages(0).Visible = Fals
Exit Sub
errHandler:
'if error occurs then show me exactly where the error occurs
MsgBox "Error " & Err.Number & _
" (" & Err.Description & ")in procedure PcmdClear_Click of Form ProjectDB"
End Sub
Now when I try to update the newly created Worksheet (named after the project) I get the error:
Run-time error '424':
Object required
On the line:
Set WS = ThisWorksheet.Sheets(ProjectName)
I think that Gary's Student answer is missing the step where after I create the new sheet I start collecting the data.
Here is one way to use the Name:
Sub FreshSheet()
Dim PublicStringNAme As String
PublicStringNAme = "Ellan"
Sheets("My_Tamplate").Copy After:=Worksheets(Sheets.Count)
ActiveSheet.Name = PublicStringNAme
'
'
'
'
Sheets(PublicStringNAme).Range("A1") = 1
End Sub
If you want to make the variable "more Global" then:
Public PublicStringName As String
Sub FreshSheet()
PublicStringName = "Ellan"
Sheets("My_Tamplate").Copy After:=Worksheets(Sheets.Count)
ActiveSheet.Name = PublicStringName
'
'
'
'
Sheets(PublicStringName).Range("A1") = 1
End Sub
See:
Scope
Can someone help me with below code? Here is a piece of code that is intended to copy a list of emails id's from "Sheet1" cells "B2" to "n" number of rows having data.
I am facing two issues with this.
1) HTMLBody text is not copied to email.
2) List of email recipient available at Sheet1, B2 onward is not getting copied on email recipient list ("To" list).
Thanks in advance!
Sub MeetingMacro()
'MsgBox Hour(Now)
If Weekday(Now, vbMonday) >= 6 And Hour(Now) > 12 Then
Exit Sub
End If
Application.ScreenUpdating = False
Dim pt As PivotTable
Set pt = ThisWorkbook.Sheets("Sheet2").PivotTables("PivotTable")
pt.RefreshTable
Application.CalculateUntilAsyncQueriesDone
Call saveAsXlsx1
Application.CalculateUntilAsyncQueriesDone
Call savefile
Application.CalculateUntilAsyncQueriesDone
Call Send_Range
'Call Send_Range
End Sub
Sub Send_Range()
Dim TBL As ListObject
ThisWorkbook.Activate
ThisWorkbook.EnvelopeVisible = False
ThisWorkbook.Sheets("Sheet2").Range("A1:B30").Select
ThisWorkbook.Activate
With ActiveSheet.MailEnvelope
SDest = ""
For iCounter = 2 To WorksheetFunction.CountA(Columns(3))
If SDest = "" Then
SDest = Cells(iCounter, 3).Value
SDest.Value.Select
Else
SDest = SDest & ";" & Cells(iCounter, 3).Value
End If
Next iCounter
.Item.To = SDest
.Item.CC = "someone#example.com"
.Item.Subject = "[URGENT] Meeting has been cancelled. "
.Item.HTMLBody = "Hello," & vbCrLf & "Meeting has been cancelled. Fresh invite will be sent soon.” & vbCrLf & "Regards"
.Item.Attachments.Add "C:\Attachment.xlsx" 'ActiveWorkbook.FullName
.Item.Send
End With
'MsgBox (TimeOfDay)
End Sub
'MsgBox (TimeOfDay)
Sub savefile()
Application.ScreenUpdating = False
ThisWorkbook.Activate
Application.ScreenUpdating = True
ThisWorkbook.Save
End Sub
Sub saveAsXlsx1()
ThisWorkbook.Worksheets(Array("Sheet2")).Copy
Application.DisplayAlerts = False
ActiveSheet.Shapes.Range("FetchData").Delete
ActiveWorkbook.SaveAs Filename:="C:\Attachment.xlsx"
ActiveWorkbook.Close
End Sub
Sub Meeting4()
ThisWorkbook.Application.DisplayAlerts = False
ActiveWorkbook.Save
ThisWorkbook.Close
End Sub
Say you have cells B2:B30 (all in the same column) in Sheet1, containing email addresses. What you want is to grab the values in these cells, and turn them into a one-dimensional array - that's done like this:
Dim values As Variant
values = Application.WorksheetFunction.Transpose(Sheet1.Range("B2:B30").Value)
With a one-dimensional array of email addresses, all you need to do is to turn it into a String. The Join function is made exactly for that:
Dim recipients As String
recipients = Join(values, ";")
That's all! ...assuming the cells all contain an email address string. If one cell contains an error value, expect trouble. If there are blanks, expect blanks (shouldn't make a difference though). If the range to grab isn't carved in stone, research how to make it more dynamic.
The HtmlBody is expecting an HTML-encoded string that contains HTML markup. If you only have plain text, use the Body property instead.
I'm trying to create a macro for a command button that when clicked, will get the job number from that row and look for a file for that job. If it does not exist I want it to copy from a template and save with a new name, otherwise just open the file.
However, I cannot seem to work out how to get hold of the information for the command button that calls the macro. This is what I have so far:
Public Function ShapeExists(OnSheet As Object, Name As String) As Boolean
On Error GoTo ErrShapeExists
If Not OnSheet.Shapes(Name) Is Nothing Then
ShapeExists = True
End If
ErrShapeExists:
Exit Function
End Function
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim buttonName As String
buttonName = (Target.Row - 1)
If Not ShapeExists(ActiveSheet, buttonName) Then
If Range("O" & Target.Row).Value = "" And Target.Column <= 14 And Target.Row > 1 Then
ActiveSheet.Buttons.Add(910.5, Range("O" & Target.Row).Top, 80, 20).Select
Selection.Name = buttonName
Selection.OnAction = "Sheet1.JobButton"
ActiveSheet.Shapes(buttonName).Select
Selection.Characters.Text = "Open Job"
End If
End If
End Sub
Private Sub JobButton()
Dim newText As String
ActiveSheet.Shapes(Application.Caller).Select
If Range("N" & Selection.TopLeftCell.Row).Value <> "" Then
newText = "Job " & Range("N" & Selection.TopLeftCell.Row).Value
Dim checkFilename As String
Dim check As String
check = "N" & Selection.TopLeftCell.Row
checkFilename = newText & ".xlsm"
If Dir(checkFilename) <> "" Then
Workbooks.Open (newText)
Else
Dim SrcBook As Workbook
Set SrcBook = ThisWorkbook
Dim NewBook As Workbook
NewBook = Workbooks.Open("Job Template.xlsm")
SrcBook.Worksheets(1).Range("D" & Selection.TopLeftCell.Row).Copy
NewBook.Worksheets(2).Range("B15").PasteSpecial
With NewBook
.Title = newText
.Subject = newText
.SaveAs Filename:=newText
End With
End If
Else
ErrMsg:
MsgBox ("Job Should always have a number."), , "NO JOB NUMBER"
End If
End Sub
As you can see I am currently trying ActiveSheet.Shapes(Application.Caller).Select, this is causing a "Run-time error '13': Type mismatch".
Any help would be much appreciated, thank you!
Right-click the button --> View Code --> put your JobButton code here