I want to make an excel calendar interactive. When I click on a day, I want it to take the user to a new box/screen/cell where they can see a day schedule instead of the default month schedule.
I know I can hyperlink each cell to another cell on a different page but that would be very tedious. How can I automate this?
You can link the cell so when a user clicks into it, normally toggling the cell to be changed, it instead takes triggers an event. Here is some code that will trigger an event when a desired cell is selected posted by "iwrk4dedpr" on ozgrid.com. As for the actual code you would input to take the user to a new sheet with all the days events on it, well you specifically asked me to not tell you the answer. Have Fun looking/Learning!
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Do something if Cell(1,1) or Range("A1") has been selected
if target.row = 1 and target.column = 1 then
' your code in here
end if
End Sub
You can try:
Option Explicit
Dim ThisDay As Date
Dim ThisYear, ThisMth As Date
Dim CreateCal As Boolean
Dim i As Integer
Private Sub HelpLabel_Click()
End Sub
Private Sub UserForm_Initialize()
Application.EnableEvents = False
'starts the form on todays date
ThisDay = Date
ThisMth = Format(ThisDay, "mm")
ThisYear = Format(ThisDay, "yyyy")
For i = 1 To 12
CB_Mth.AddItem Format(DateSerial(Year(Date), Month(Date) + i, 0), "mmmm")
Next
CB_Mth.ListIndex = Format(Date, "mm") - Format(Date, "mm")
For i = -20 To 50
If i = 1 Then CB_Yr.AddItem Format((ThisDay), "yyyy") Else CB_Yr.AddItem _
Format((DateAdd("yyyy", (i - 1), ThisDay)), "yyyy")
Next
CB_Yr.ListIndex = 21
'Builds the calendar with todays date
CalendarFrm.Width = CalendarFrm.Width
CreateCal = True
Call Build_Calendar
Application.EnableEvents = True
End Sub
Private Sub CB_Mth_Change()
'rebuilds the calendar when the month is changed by the user
Build_Calendar
End Sub
Private Sub CB_Yr_Change()
'rebuilds the calendar when the year is changed by the user
Build_Calendar
End Sub
Private Sub Build_Calendar()
'the routine that actually builds the calendar each time
If CreateCal = True Then
CalendarFrm.Caption = " " & CB_Mth.Value & " " & CB_Yr.Value
'sets the focus for the todays date button
CommandButton1.SetFocus
For i = 1 To 42
If i < Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value)) Then
Controls("D" & (i)).Caption = Format(DateAdd("d", (i - Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), _
((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "d")
Controls("D" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), _
((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "m/d/yy")
ElseIf i >= Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value)) Then
Controls("D" & (i)).Caption = Format(DateAdd("d", (i - Weekday((CB_Mth.Value) _
& "/1/" & (CB_Yr.Value))), ((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "d")
Controls("D" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), _
((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "m/d/yy")
End If
If Format(DateAdd("d", (i - Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), _
((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "mmmm") = ((CB_Mth.Value)) Then
If Controls("D" & (i)).BackColor <> &H80000016 Then Controls("D" & (i)).BackColor = &H80000018 '&H80000010
Controls("D" & (i)).Font.Bold = True
If Format(DateAdd("d", (i - Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), _
((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "m/d/yy") = Format(ThisDay, "m/d/yy") Then Controls("D" & (i)).SetFocus
Else
If Controls("D" & (i)).BackColor <> &H80000016 Then Controls("D" & (i)).BackColor = &H8000000F
Controls("D" & (i)).Font.Bold = False
End If
Next
End If
End Sub
Private Sub D1_Click()
'this sub and the ones following represent the buttons for days on the form
'retrieves the current value of the individual controltiptext and
'places it in the active cell
ActiveCell.Value = D1.ControlTipText
Unload Me
'after unload you can call a different userform to continue data entry
'uncomment this line and add a userform named UserForm2
'Userform2.Show
End Sub
Private Sub D2_Click()
ActiveCell.Value = D2.ControlTipText
Unload Me
End Sub
Private Sub D3_Click()
ActiveCell.Value = D3.ControlTipText
Unload Me
End Sub
Private Sub D4_Click()
ActiveCell.Value = D4.ControlTipText
Unload Me
End Sub
Private Sub D5_Click()
ActiveCell.Value = D5.ControlTipText
Unload Me
End Sub
Private Sub D6_Click()
ActiveCell.Value = D6.ControlTipText
Unload Me
End Sub
Private Sub D7_Click()
ActiveCell.Value = D7.ControlTipText
Unload Me
End Sub
Private Sub D8_Click()
ActiveCell.Value = D8.ControlTipText
Unload Me
End Sub
Private Sub D9_Click()
ActiveCell.Value = D9.ControlTipText
Unload Me
End Sub
Private Sub D10_Click()
ActiveCell.Value = D10.ControlTipText
Unload Me
End Sub
Private Sub D11_Click()
ActiveCell.Value = D11.ControlTipText
Unload Me
End Sub
Private Sub D12_Click()
ActiveCell.Value = D12.ControlTipText
Unload Me
End Sub
Private Sub D13_Click()
ActiveCell.Value = D13.ControlTipText
Unload Me
End Sub
Private Sub D14_Click()
ActiveCell.Value = D14.ControlTipText
Unload Me
End Sub
Private Sub D15_Click()
ActiveCell.Value = D15.ControlTipText
Unload Me
End Sub
Private Sub D16_Click()
ActiveCell.Value = D16.ControlTipText
Unload Me
End Sub
Private Sub D17_Click()
ActiveCell.Value = D17.ControlTipText
Unload Me
End Sub
Private Sub D18_Click()
ActiveCell.Value = D18.ControlTipText
Unload Me
End Sub
Private Sub D19_Click()
ActiveCell.Value = D19.ControlTipText
Unload Me
End Sub
Private Sub D20_Click()
ActiveCell.Value = D20.ControlTipText
Unload Me
End Sub
Private Sub D21_Click()
ActiveCell.Value = D21.ControlTipText
Unload Me
End Sub
Private Sub D22_Click()
ActiveCell.Value = D22.ControlTipText
Unload Me
End Sub
Private Sub D23_Click()
ActiveCell.Value = D23.ControlTipText
Unload Me
End Sub
Private Sub D24_Click()
ActiveCell.Value = D24.ControlTipText
Unload Me
End Sub
Private Sub D25_Click()
ActiveCell.Value = D25.ControlTipText
Unload Me
End Sub
Private Sub D26_Click()
ActiveCell.Value = D26.ControlTipText
Unload Me
End Sub
Private Sub D27_Click()
ActiveCell.Value = D27.ControlTipText
Unload Me
End Sub
Private Sub D28_Click()
ActiveCell.Value = D28.ControlTipText
Unload Me
End Sub
Private Sub D29_Click()
ActiveCell.Value = D29.ControlTipText
Unload Me
End Sub
Private Sub D30_Click()
ActiveCell.Value = D30.ControlTipText
Unload Me
End Sub
Private Sub D31_Click()
ActiveCell.Value = D31.ControlTipText
Unload Me
End Sub
Private Sub D32_Click()
ActiveCell.Value = D32.ControlTipText
Unload Me
End Sub
Private Sub D33_Click()
ActiveCell.Value = D33.ControlTipText
Unload Me
End Sub
Private Sub D34_Click()
ActiveCell.Value = D34.ControlTipText
Unload Me
End Sub
Private Sub D35_Click()
ActiveCell.Value = D35.ControlTipText
Unload Me
End Sub
Private Sub D36_Click()
ActiveCell.Value = D36.ControlTipText
Unload Me
End Sub
Private Sub D37_Click()
ActiveCell.Value = D37.ControlTipText
Unload Me
End Sub
Private Sub D38_Click()
ActiveCell.Value = D38.ControlTipText
Unload Me
End Sub
Private Sub D39_Click()
ActiveCell.Value = D39.ControlTipText
Unload Me
End Sub
Private Sub D40_Click()
ActiveCell.Value = D40.ControlTipText
Unload Me
End Sub
Private Sub D41_Click()
ActiveCell.Value = D41.ControlTipText
Unload Me
End Sub
Private Sub D42_Click()
ActiveCell.Value = D42.ControlTipText
Unload Me
End Sub
Related
Form 1
I am getting the code to wire to the database file but the check if the value from text box 2 is already in column B throw a message and exit is not working Also if the database is open I am not getting an error it just freezes.
Form 2
I am getting the spinning wheel. It is how it is supposed to work is if textbox1 value is already in column B add time data to column F of that row if it is textbox 1 value is not found in B throw a massage
Any help is appreciated
FORM 1 CODE
Private Sub CommandButton1_Click()
'check to see is all data is filled in
If TextBox1.Value = "" Or TextBox2.Value = "" Or _
TextBox3.Value = "" Or TextBox4.Value = "" Or TextBox5.Value = "" Then
MsgBox "YOU DID NOT FILL IN ALL THE INFO."
Exit Sub
End If
Call Submit_Data
Call resetForm
Unload Me
End Sub
Sub resetForm()
TextBox1.Value = ""
TextBox2.Value = ""
TextBox3.Value = ""
TextBox4.Value = ""
TextBox5.Value = ""
UserForm1.TextBox1.SetFocus
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub UserForm_Click()
End Sub
Sub Submit_Data()
Application.ScreenUpdating = False
Dim App As New Excel.Application
Dim wBook As Excel.Workbook
Dim FileName As String
Dim iRow As Long
FileName = ThisWorkbook.Path & "\test.xlsm"
'Check File Exist or Not
'If Dir(FileName) = "" Then
'MsgBox "Database File is missing. Unable to proceed.", vbOKOnly vbCritical, "Error"
'Exit Sub
'End If
Set wBook = App.Workbooks.Open(FileName)
App.Visible = False
If wBook.ReadOnly = True Then
MsgBox "Database is in use. Please try after sometimes.", vbookonly + vbCritical, "error"
Exit Sub
End If
'Transfer the Data
id = TextBox2.Value
With wBook.Sheets("test")
Set ws = wBook.Sheets("test")
m = Application.Match(id, ws.Columns("B"), 0) 'try to match an existing row
If IsError(m) Then 'no match?
iRow = .Range("A" & Application.Rows.Count).End(xlUp).Row + 1
.Range("A" & iRow).Value = TextBox1.Value 'Cell
.Range("B" & iRow).Value = TextBox2.Value 'workorder number
.Range("C" & iRow).Value = TextBox3.Value 'product number
.Range("D" & iRow).Value = TextBox4.Value 'Work order quanity
.Range("E" & iRow).Value = Date 'date
.Range("F" & iRow).Value = Time 'time
.Range("M" & iRow).Value = TextBox5.Value 'crew size
Else
MsgBox "JOB ALREADY CLOCKED IN!"
Exit Sub
End If
End With
wBook.Close Savechanges:=True
App.Quit
Set App = Nothing
'Reset the form
Call resetForm
Application.ScreenUpdating = True
MsgBox "Data submitted successfully!"
End Sub
FORM 2 CODE
Private Sub CommandButton1_Click()
'check to see is all data is filled in
If TextBox1.Value = "" Then
MsgBox "YOU DID NOT ENTER WO."
Exit Sub
End If
Call Submit_Data
Call resetForm
Unload Me
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Sub Submit_Data()
Application.ScreenUpdating = False
Dim App As New Excel.Application
Dim wBook As Excel.Workbook
Dim FileName As String
Dim iRow As Long
FileName = ThisWorkbook.Path & "\Database.xlsm"
'Check File Exist or Not
'If Dir(FileName) = "" Then
'MsgBox "Database File is missing. Unable to proceed.", vbOKOnly vbCritical, "Error"
'Exit Sub
'End If
Set wBook = App.Workbooks.Open(FileName)
App.Visible = False
If wBook.ReadOnly = True Then
MsgBox "Database is in use. Please try after sometimes.", vbookonly + vbCritical, "error"
Exit Sub
End If
'Transfer the Data
id = TextBox1.Value
With wBook.Sheets("Database")
m = Application.Match(id, ("B"), 0) 'try to match an existing row
If IsError(m) Then 'no match?
MsgBox "NEVER CLOCKED IN"
Exit Sub
End If
With ws.Rows(m)
.Columns("F").Value = Time
wBook.Close Savechanges:=True
App.Quit
Set App = Nothing
'Reset the form
Call resetForm
Application.ScreenUpdating = True
MsgBox "Data submitted successfully!"
End With
End With
End Sub
Sub resetForm()
TextBox1.Value = ""
UserForm1.TextBox1.SetFocus
End Sub
Private Sub UserForm_Click()
End Sub
If the ID values on your "database" sheet are numeric, you need to use a numeric input for Match(), so:
'Transfer the Data
id = CLng(TextBox2.Value) '<<< assuming the value is numeric: may want to add a check...
With wBook.Sheets("test")
Set ws = wBook.Sheets("test")
m = Application.Match(id, ws.Columns("B"), 0) 'try to match an existing row
If IsError(m) Then 'no match?
iRow = .Range("A" & Application.Rows.Count).End(xlUp).Row + 1
'etc
'etc
You don't need a separate instance of Excel to save the record - it's better to just open the file in the existing instance.
Also - if you're planning on not closing the file immediately after populating the data row, you need to check to see if it's already open when you perform the next save: opening a file which is already open can give unexpected results. See https://stackoverflow.com/a/56262538/478884
I created a data entry form in Excel.
I would like that input to be stored in another sheet (Table format).
Code I found online and modified:
Function ValidateForm() As Boolean
SellerSKU.BackColor = vbWhite
Description.BackColor = vbWhite
ValidateForm = True
If Trim(SellerSKU.Value) = "" Then
MsgBox "SKU can't be left blank.", vbOKOnly + vbInformation, "SKU"
SellerSKU.BackColor = vbRed
SellerSKU.Activate
ValidateForm = False
ElseIf Trim(Description.Value) = "" Then
MsgBox "Description can't be left blank.", vbOKOnly + vbInformation, "Description"
Description.BackColor = vbRed
Description.Activate
ValidateForm = False
End If
End Function
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
SellerSKU.Value = ""
SellerSKU.BackColor = vbWhite
Description.Value = ""
Description.BackColor = vbWhite
End Sub
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim iRow As Long
iRow = Sheets("Reference Sheet (Order Hist)").Range("A1048576").End(xlUp).Row + 1
If ValidateForm = True Then
With ThisWorkbook.Sheets("Reference Sheet (Order Hist)")
.Range("A" & iRow).Value = SellerSKU.Value
.Range("C" & iRow).Value = Description.Value
End With
Call Reset
Else
Application.ScreenUpdating = False
Exit Sub
End If
Application.ScreenUpdating = True
End Sub
When I hit "Enter" on the data entry form, the table on the other sheet does not get updated.
Also is it possible to clear the form every time an entry has been successfully made?
This worked for me. Re-organized and removed some of the repetition...
Private Sub CommandButton2_Click()
Dim iRow As Long, valErrors As String
valErrors = ValidationErrors() 'checks the form
If Len(valErrors) = 0 Then
'no errors - add the data
With ThisWorkbook.Worksheets("Reference Sheet (Order Hist)")
iRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & iRow).Value = SellerSKU.Value
.Range("C" & iRow).Value = Description.Value
End With
ResetForm 'Call keyword is deprecated...
Else
MsgBox "One or more errors in form entries:" & vbLf & vbLf & valErrors, _
vbOKOnly + vbExclamation, "Check form data"
End If
End Sub
'check the form and return a listing of any errors
Function ValidationErrors() As String
Dim msg As String
CheckNonBlank SellerSKU, "SKU can't be left blank.", msg
CheckNonBlank Description, "Description can't be left blank.", msg
ValidationErrors = msg
End Function
'utility sub - check if a control has text, flag as error if missing,
' and add some text to the overall validation message
Sub CheckNonBlank(cntrl As Object, msgErr As String, ByRef msg As String)
Dim isErr As Boolean
isErr = Len(Trim(cntrl.Value)) = 0 'true if no content
ErrorFlag cntrl, isErr
If isErr And Len(msgErr) > 0 Then
msg = msg & IIf(Len(msg) > 0, vbLf, "") & msgErr 'append this error
End If
End Sub
Private Sub CommandButton1_Click()
ResetForm
End Sub
'clear textboxes and any error flags
Sub ResetForm()
SellerSKU.Value = ""
ErrorFlag SellerSKU, False
Description.Value = ""
ErrorFlag Description, False
End Sub
'flag a control as having a problem (pass False to second parameter to clear flag)
Sub ErrorFlag(cntrl As Object, Optional HasError As Boolean = True)
cntrl.BackColor = IIf(HasError, vbRed, vbWhite)
End Sub
i want to create a sub that records in a list how many times you pressed the return key in the current session (it should write on a new line each time you reopen the file)
heres are my attempts:
somehow it's not working
Option Explicit
Private Sub Worksheet_activated(ByVal target As Range)
Target.Value = target.Value + 1
Application.OnKey "~", "CountDT"
End Sub
Private Sub worksheet_deactivated()
Application.OnKey "~"
End Sub
Option Explicit
Sub CountDT()
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = ActiveCell.Value & " " & Date & " " & Time
End Sub
In the worksheet code module:
Option Explicit
Private Sub Worksheet_Activate()
Application.OnKey "~", Me.CodeName & ".CountDT"
End Sub
Private Sub Worksheet_Deactivate()
Application.OnKey "~"
End Sub
Sub CountDT()
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = ActiveCell.Value & " " & Date & " " & Time
End Sub
I have below code which has to cut the data and copy into another sheet called data_base but its not happening its copying the data in username-password.xlsx and i am facing one more problem is once i try to close the userform Logout button should appear when i click on logout button its giving error at line "Worksheets("data1").Range("B1").Value = Date & " " & Time ' as subscript out of range.
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!"
Worksheets("data1").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
Private Sub CommandButton6_Click()
Worksheets("data1").Range("B1").Value = Date & " " & Time
Selection.NumberFormat = "m/d/yyyy h:mm AM/PM"
ThisWorkbook.Save
Worksheets("data1").Range("A1:B1").Select
Selection.Cut
Unload Me
getlogindata
ActiveWorkbook.Close True
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
End If
End Sub
Sub getlogindata()
Dim info
info = IsWorkBookOpen("D:\TMS_Project\Log_Details..xlsx")
' we open the workbook if it is closed
If info = False Then
Workbooks.Open ("D:\TMS_Project\Log_Details..xlsx")
End If
Worksheets("data_base").Activate
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("data_base").Range(Cells(erow, 1), Cells(erow, 2))
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.Quit
End Sub
any help is appreciated as i got stuck at this and could not able to progress with my login and logout system.
I don't think you have a sheet called "data1" in the currently active workbook. Try fully qualifying the reference as
Workbooks("Log_Details..xlsx").worksheets("data1").range("B1")= Date & " " & Time
or Activate the desired workbook first
I'm using John Walkenbach code to export a chart as a GIF and then load it onto a user form. The problem I'm having is With this bit here Image1.Picture = LoadPicture(Fname). It is not loading the GIF onto the UserForm. It exports the Image fine I can see it in the same directory as my excel file.
Private Sub CommandButton1_Click()
Call GetChart
Image1.Picture = LoadPicture(Fname)
MsgBox "Yep"
End Sub
Public Sub GetChart()
Set CurrentChart = Sheets("StatsDB").ChartObjects(1).Chart
Fname = ThisWorkbook.Path & "/temp.gif"
CurrentChart.Export Filename:=Fname, FilterName:="GIF"
End Sub
You need to assign a value to Fname before you use it. There are several way of doing that:
1) Just assigning the value in CommandButton1_Click
Private Sub CommandButton1_Click()
GetChart
Fname = ThisWorkbook.Path & "/temp.gif"
Image1.Picture = LoadPicture(Fname)
MsgBox "Yep"
End Sub
Public Sub GetChart()
Set CurrentChart = Sheets("StatsDB").ChartObjects(1).Chart
Fname = ThisWorkbook.Path & "/temp.gif"
CurrentChart.Export Filename:=Fname, FilterName:="GIF"
End Sub
2) Passing the value you used in GetChart back as a "return" value:
Private Sub CommandButton1_Click()
Fname = GetChart()
Image1.Picture = LoadPicture(Fname)
MsgBox "Yep"
End Sub
Public Function GetChart() As String
Set CurrentChart = Sheets("StatsDB").ChartObjects(1).Chart
Fname = ThisWorkbook.Path & "/temp.gif"
CurrentChart.Export Filename:=Fname, FilterName:="GIF"
GetChart = Fname
End Sub
3) Making Fname module-level in scope:
Dim Fname As String
Private Sub CommandButton1_Click()
GetChart
Image1.Picture = LoadPicture(Fname)
MsgBox "Yep"
End Sub
Public Sub GetChart()
Set CurrentChart = Sheets("StatsDB").ChartObjects(1).Chart
Fname = ThisWorkbook.Path & "/temp.gif"
CurrentChart.Export Filename:=Fname, FilterName:="GIF"
End Sub
4) Combining the two subroutines into one:
Private Sub CommandButton1_Click()
Set CurrentChart = Sheets("StatsDB").ChartObjects(1).Chart
Fname = ThisWorkbook.Path & "/temp.gif"
CurrentChart.Export Filename:=Fname, FilterName:="GIF"
Image1.Picture = LoadPicture(Fname)
MsgBox "Yep"
End Sub
There would be lots more ways of doing this, but hopefully one of the above appeals to you.