I've created a button, then assigned a macro to it which is in module1. when I select a cell within a range, then press the button, I want that cell to be given a value. if a cell within the range is not selected then pressing the button should pop up with a message box. I am just starting to write the code and already getting an issue.
If Intersect(Target, Range("D12:AS23")) Is Nothing Then
MsgBox "Please select a date.", , "Error"
Exit Sub
Else
Edit: I've got past this issue now using active cell instead of the target. but now I'm struggling again at the next bit. its saying application/object-defined error and highlighting this line. full code below
Cells(LastRow, 2).Value = Application.SumIf(Sheets("Settings").range("ListEmployeeNames"), Cells(3, 2).Value, Sheets("Settings").range("ListEmployeeID"))
Sub AddNote()
Dim SelectedDate As Date
SelectedDate = Cells(ActiveCell.Row, 2) - 1 + ActiveCell.Value
If intersect(ActiveCell, range("D12:AS23")) Is Nothing Then
MsgBox "Please select a date.", , "Error"
Exit Sub
Else
With Sheets("Notes")
xtt = Application.InputBox("Insert your Comment here", "Comment")
If xtt = vbNullString Or xtt = False Then
End If
Dim LastRow As Integer
LastRow = 2 + .listobjects("TblNotes").range.rows.Count
Cells(LastRow, 2).Value = Application.SumIf(Sheets("Settings").range("ListEmployeeNames"), Cells(3, 2).Value, Sheets("Settings").range("ListEmployeeID"))
Cells(LastRow, 4).Value = SelectedDate
Cells(LastRow, 5).Value = xht
End With
End If
End Sub
Got it working 90% on my own, thanks to #LeeLiFong for tipping me off about "target" being an issue and also #BraX for point int he right direction about including arguements to qualify things. I cant accept my answer for another 48 hours.
Dim SelectedDate As Date
SelectedDate = Cells(ActiveCell.Row, 2) - 1 + ActiveCell.Value
If intersect(ActiveCell, range("D12:AS23")) Is Nothing Then
MsgBox "Please select a date.", , "Error"
Exit Sub
Else
Call SmoothCodeStart
With Sheets("Notes")
xt4 = Application.InputBox("Insert your Comment here", "Comment")
If xt4 = vbNullString Or xt4 = False Then
End If
Dim LastRow As Integer
LastRow = 2 + .listobjects("TblNotes").range.rows.Count
.Cells(LastRow, 2).Value = Application.SumIf(Sheets("Settings").range("ListEmployeeNames"), Cells(3, 2).Value, Sheets("Settings").range("ListEmployeeID"))
.Cells(LastRow, 4).Value = SelectedDate
.Cells(LastRow, 6).Value = xt4
End With
Call SmoothCodeEnd
End If
Related
My first Sub uses a value that I enter in a userform to search a table on another sheet and update the userform with the currently entered values from that sheet.
I have a second Sub that will write the updated values back to the same sheet. I have a checkbox that the user checks when the the related project is complete and we no longer need the data in the row and would like it deleted.
When this is checked and the user clicks update, the sub is to delete that Row from the sheet.
The main sheet is just a replica of the sheet that contains the actual data. That sheet receives updates from Zapier. I have macros that hide rows and columns and this messes with connected apps when they try to add data which is the reason for the second sheet.
I have spent all day today trying to figure out how to delete the row that has been selected
by the search function in the userform. The sub performs the same search when updating the row so I thought if I added an IF statement to either update or delete depending on the status of the checkbox.
Here is my code as it stands:
Private Sub UpdateRecord()
Dim RecordRow As Long
Dim RecordRange As Range
Dim Answer As VbMsgBoxResult
Dim DeleteRow As Long
Dim DeleteRange As Range
Dim ws As String
' Find the row in the table that the record is in
RecordRow = Application.Match(CLng(TextBoxWO.Value), Range("JobSheetData[W/O]"), 0)
' Set RecordRange to the first cell in the found record
Set RecordRange = Range("JobSheetData").Cells(1, 1).Offset(RecordRow - 1, 0)
If CheckBoxDelete = "True" Then
'---------------------True = Delete-------------------
' Find the row in the table that the record is in
DeleteRow = Application.Match(CLng(TextBoxWO.Value), Range("JobSheetData[W/O]"), 0)
' Set RecordRange to the first cell in the found record
Set DeleteRange = Range("JobSheetData").Cells(1, 1).Offset(RecordRow - 1, 0)
Answer = MsgBox("Are you sure you want to PERMANENTLY DELETE this job from the job list?" & vbCrLf & vbCrLf & "This action cannot be undone!", vbOKCancel + vbDefaultButton2, "Confirm removal of job from list")
If Answer = vbYes Then
ActiveWorkbook.Worksheets("Job List Import").ListObjects("JobSheetData").ListRows(DeleteRange).Delete
End If
'---------------------False = Update-------------------
Else
RecordRange(1, 1).Offset(0, 5).Value = TextBoxHold.Value
RecordRange(1, 1).Offset(0, 7).Value = TextBoxDays.Value
RecordRange(1, 1).Offset(0, 9).Value = CheckBoxLocate.Value
RecordRange(1, 1).Offset(0, 13).Value = TextBoxFirst.Value
RecordRange(1, 1).Offset(0, 14).Value = TextBoxOveride.Value
RecordRange(1, 1).Offset(0, 15).Value = CheckBoxBell.Value
RecordRange(1, 1).Offset(0, 16).Value = CheckBoxGas.Value
RecordRange(1, 1).Offset(0, 17).Value = CheckBoxHydro.Value
RecordRange(1, 1).Offset(0, 18).Value = CheckBoxWater.Value
RecordRange(1, 1).Offset(0, 19).Value = CheckBoxCable.Value
RecordRange(1, 1).Offset(0, 20).Value = CheckBoxOther1.Value
RecordRange(1, 1).Offset(0, 21).Value = CheckBoxOther2.Value
RecordRange(1, 1).Offset(0, 22).Value = CheckBoxOther3.Value
End If
End Sub
I also tried to incorporate this code but could not get it to work either:
Dim Answer As VbMsgBoxResult
Answer = MsgBox("Are you sure you want to PERMANENTLY DELETE this job from the job list?" & vbCrLf & vbCrLf & "This action cannot be undone!", vbOKCancel + vbDefaultButton2, "Confirm removal of job from list")
If Answer = vbYes Then
If JobSheetInputForm.ListRows.Count < 1 Then Exit Sub
With ActiveSheet.ListObjects("JobSheet")
JobSheetInputForm.ListRows(CurrentRow).Delete
If JobSheetInputForm.ListRows.Count > 0 Then
If CurrentRow > JobSheetInputForm.ListRows.Count Then
CurrentRow = JobSheetInputForm.ListRows.Count
End If
JobSheetInputForm.ListRows(CurrentRow).Range.Select
Else
CurrentRow = 0
End If
End With
End If
I am beat at this point and need your Help! Thank you!
Something like this:
Sub Test()
Dim rngSrch As Range, lo As ListObject, DeleteRow, v
Set lo = ActiveWorkbook.Worksheets("Job List Import").ListObjects("JobSheetData")
Set rngSrch = lo.ListColumns("W/O").DataBodyRange 'range to search in
v = CLng(TextBoxWO.Value) 'value to search
DeleteRow = Application.Match(v, rngSrch, 0) 'try to match a row
If Not IsError(DeleteRow) Then 'got match?
If MsgBox("Are you sure you want to PERMANENTLY DELETE this job from the job list?" & _
vbCrLf & vbCrLf & "This action cannot be undone!", _
vbOKCancel + vbDefaultButton2, "Confirm removal of job from list") = vbOK Then
lo.ListRows(DeleteRow).Delete
End If
Else
MsgBox "Value not found!" 'no match
End If
End Sub
I am trying to reset the document to default based on the value in Column E or 5. I would then like to change the value of the cell in both column 5 and 7.
When I run without the Cells (x,7) lines it works.
Sub Reset_Submitted_Document_HW_ALSTOM()
ActiveSheet.Unprotect
Dim answer As Integer
answer = MsgBox("Do you want to reset the Submittted Document for Sign Of Year? This is typically performed at year end to clear the tracker.", vbQuestion + vbYesNo + vbDefaultButton2, "Reset Submitted Document Checkmark")
If answer = vbYes Then
Application.ScreenUpdating = False
For x = 1 To Cells(Rows.Count, "E").End(xlUp).Row
Select Case (Cells(x, 5))
Case "Reset Default Date"
Cells(x, 5) = "Reset Default Date"
Cells(x, 7).Formula = "=Today()"
Case "Final Update"
Cells(x, 5) = "Reset Default Date"
Cells(x, 7).Formula = "=Today()"
Case "Final Action Taken SPD"
Cells(x, 5) = "Populate Previous SPD"
Cells(x, 7) = ""
Case "Populate Previous SPD"
Cells(x, 5) = "Populate Previous SPD"
Cells(x, 7) = ""
Case Else
Cells(x, 5).Formula = "="""""
End Select
Next x
Application.ScreenUpdating = True
Else
MsgBox "No Updates have been made to the tracker."
End If
ActiveSheet.Protect
End Sub
Update: The answered code runs but does not change the date, nor reset cells in column E that say "Final Update" to "Reset Default Date". I'm thinking it may have something to do with xlUp stopping part way down column E.
Screenshot of how the sheet is structured.
Some Minor Corrections
If you don't use Option Explicit (not recommended), there is no error. When you use it, there is a compile error because x isn't dimmed.
The lines that contain .formula should be changed, because e.g. the data will be changed to the date when you open the workbook again, but you need the date when the reset was done. Similarly you don't want the formula ="" in a column with only values.
If you want to do the same thing for two conditions in a Select Case statement, you separate them by a comma in the same case. The comma means Or.
If the code stops in the middle, ScreenUpdating will stay False. Do some Error handling.
Option Explicit
Sub Reset_Submitted_Document_HW_ALSTOM()
ActiveSheet.Unprotect
Dim answer As Long
Dim x As Long
answer = MsgBox("Do you want to reset the Submittted Document " _
& "for Sign Of Year? This is typically performed at year end to clear " _
& "the tracker.", vbQuestion + vbYesNo + vbDefaultButton2, _
"Reset Submitted Document Checkmark")
If answer <> vbYes Then MsgBox _
"No Updates have been made to the tracker.": GoTo ProgramExit
Application.ScreenUpdating = False
On Error GoTo ProgramError
For x = 1 To Cells(Rows.Count, "E").End(xlUp).Row
Select Case (Cells(x, 5))
Case "Reset Default Date", "Final Update"
Cells(x, 5) = "Reset Default Date"
Cells(x, 7) = Date ' Cells(x, 7).Formula = "=Today()"
Case "Final Action Taken SPD", "Populate Previous SPD"
Cells(x, 5) = "Populate Previous SPD"
Cells(x, 7) = ""
Case Else
Cells(x, 5) = "" 'Cells(x, 5).Formula = "="""""
End Select
Next
SafeExit:
Application.ScreenUpdating = True
ProgramExit:
ActiveSheet.Protect
Exit Sub
ProgramError:
MsgBox "An unexpected error occurred."
On Error GoTo 0
GoTo SafeExit
End Sub
I have a list box which details inquiries and when the double click is used on a line in the list box, a second userform opens to allow the information to update, the issues i am having is the date which is supposed to come from the 13 & 14th columns is not transferring back to the text box:
.Offset(0, 13).Value, txtnotes.Value, _
.Offset(0, 14).Value, txtdtime.Value)
The other combo boxes and text boxes are taking retrieving the correct data, but it is these final boxes which will not go.
here is the complete code:
Private Sub UserForm_Initialize()
'dim the variables
Dim i As Integer
On Error Resume Next
'find the selected list item
i = frmenqnew.lstenq.ListIndex
'add the values to the text boxes
Me.txtenqup.Value = frmenqnew.lstenq.Column(0, i)
Me.txtcustup.Value = frmenqnew.lstenq.Column(1, i)
Me.cboup3.Value = frmenqnew.lstenq.Column(4, i)
Me.cboup4.Value = frmenqnew.lstenq.Column(5, i)
Me.cboup5.Value = frmenqnew.lstenq.Column(6, i)
Me.cboup6.Value = frmenqnew.lstenq.Column(7, i)
Me.txtrev.Value = frmenqnew.lstenq.Column(9, i)
Me.txtnotes.Value = frmenwnew.lstenq.Column(13, i)
Me.txtdtime.Value = frmenwnew.lstenq.Column(14, i)
With cboup5
.AddItem "Active"
.AddItem "Dormant"
.AddItem "Lost"
.AddItem "Sold"
End With
With cboup6
.AddItem "Drawing"
.AddItem "Appraisal"
.AddItem "Verification"
.AddItem "Presenting"
End With
On Error GoTo 0
End Sub
Private Sub cmdUpdate_Click()
' To write edited info of userform2 to Sheets("Data")
Dim LastRow As Long
Dim ABnum As Double
Dim ABrng As Range
Dim WriteRow As Long
'error statement
On Error GoTo errHandler:
'hold in memory and stop screen flicker
Application.ScreenUpdating = False
' Make sure we're on the right sheet
With Sheets("Data")
' Get the last row used so can set up the search range
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
' Set the range to search for the AB number
Set ABrng = .Range("A1:A" & LastRow)
' Get the AB number from what is selected on userform2
ABnum = txtenqup.Value
' Get the row of sheet for this AB number
WriteRow = Application.Match(ABnum, ABrng, 0)
' Make this AB number the active cell
With .Cells(WriteRow, 1)
'Check for changes
If Not hasValuePairsChanges(.Offset(0, 4).Value, cboup3.Value, _
.Offset(0, 5).Value, cboup4.Value, _
.Offset(0, 6).Value, cboup5.Value, _
.Offset(0, 7).Value, cboup6.Value, _
CDate(.Offset(0, 8).Value), Date, _
CDbl(.Offset(0, 9).Value), CDbl(txtrev.Value), _
.Offset(0, 13).Value, txtnotes.Value, _
.Offset(0, 14).Value, txtdtime.Value) Then
MsgBox "No Change in Data", vbInformation, ""
Exit Sub
End If
' Write in all the editable options
.Offset(0, 4) = cboup3.Value
.Offset(0, 5) = cboup4.Value
.Offset(0, 6) = cboup5.Value
.Offset(0, 7) = cboup6.Value
.Offset(0, 8) = Date
.Offset(0, 9) = txtrev.Value
.Offset(0, 13) = txtnotes.Value
.Offset(0, 14) = txtdtime.Value
Sheets("Archive").Range("A" & Rows.Count).End(xlUp)(2).Resize(, 14).Value = .Resize(, 14).Value
End With
End With
' Filter the Data
FilterMe
' Close the form
Unload Me
MsgBox ("Enquiry E0" + Me.txtenqup.Text + " has been updated")
errHandler:
'Protect all sheets if error occurs
'Protect_All
'show error information in a messagebox
If Err.Number <> 0 Then
MsgBox "Error " & Err.Number & " just occured."
End If
End Sub
Function hasValuePairsChanges(ParamArray Args() As Variant) As Boolean
Dim n As Long
For n = 0 To UBound(Args) Step 2
If Not Args(n) = Args(n + 1) Then
hasValuePairsChanges = True
Exit Function
End If
Next
End Function
Any help much appreciated
Thanks
I recently started learning how to use VBA since I suddenly got put into a position where I need to know it. I've been doing research on coding and such but I feel like I'm messing up every step of the way. I was asked to create a userform where people could enter their time, date, production, task, and a comment box. I was also asked to have both the input sheet and the data sheet locked, on top of that my boss wanted the sheet itself to save when closed so when workers entered their information they wouldn't save.
Private Sub cmdAdd_Click()
Dim lRow As Long
Dim lPart As Long
Dim ws As Worksheet
Set ws = Worksheets("Data")
'find first empty row in database
lRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
'check for a part number
If Trim(Me.txtComment.Value) = "" Then
Me.txtComment.SetFocus
MsgBox "Comment is required"
End If
'check for a part number
If Trim(Me.ComboBox1.Value) = "" Then
Me.ComboBox1.SetFocus
MsgBox "Date is required!"
End If
'check for a part number
If Trim(Me.txtTime.Value) = "" Then
Me.txtTime.SetFocus
MsgBox "Time is required"
End If
'check for a part number
If Trim(Me.cboProject.Value) = "" Then
Me.cboProject.SetFocus
MsgBox "Project is required"
End If
'check for a part number
If Trim(Me.cboTask.Value) = "" Then
Me.cboTask.SetFocus
MsgBox "Task is required"
Exit Sub
End If
'copy the data to the database
'use protect and unprotect lines,
' with your password
' if worksheet is protected
With ws
' .Unprotect Password:="password"
.Cells(lRow, 1).Value = Me.ComboBox1.Value
.Cells(lRow, 2).Value = Me.txtTime.Value
.Cells(lRow, 3).Value = Me.txtCount.Value
.Cells(lRow, 4).Value = Me.cboUser.Value
.Cells(lRow, 5).Value = Me.cboProject.Value
.Cells(lRow, 6).Value = Me.cboTask.Value
.Cells(lRow, 7).Value = Me.txtComment.Value
' .Protect Password:="password"
'clear the data
Me.cboUser.Value = ""
Me.ComboBox1.Value = ""
Me.txtTime.Value = ""
Me.txtCount.Value = ""
Me.cboProject.Value = ""
Me.cboTask.Value = ""
Me.txtComment.Value = ""
Me.ComboBox1.Value = Format(Date, "Short Date")
MsgBox ("Work Submitted, proceed to close the form and save the workbook.")
End With
End Sub
Apologies in advance for how awful the code probably is, but it seemed to work just enough for what I was going, the only problem was that when I was recently testing it even if I had a message saying comment required or task required it would still paste information into the datasheet which I don't want to happen.
I type three entries in specific cells
[A2,B2,C2] and run code to take this data to the first empty row in a table.
The code also prevents duplicates based on the entered value in cell B2. If it already exists in the range (B2:B5000) it prevent duplicates.
The problem is it does not ignore the case.
For example:
I enter value "Acetic Acid"
After awhile I add "acetic Acid" or change any letter case.
The code adds it normally without preventing.
How do I ignore the letter case?
Sub tarheel()
LastRow = Range("A10000").End(xlUp).Row + 1
LR = Range("b10000").End(xlUp).Row + 1
For r = 5 To LR
If Cells(r, 2) = Range("b2") Then MsgBox "This Item Name already exist, No shift will done": Exit Sub
Next
Cells(LastRow, 1).Value = Range("A2").Value
Cells(LastRow, 2).Value = Range("B2").Value
Cells(LastRow, 3).Value = Range("C2").Value
Range("A2:C2").Select
Selection.ClearContents
Range("A2").Select
End Sub
thanks for all your replies and i will try it too and give feedback to you.
i could figure it out by adding this line at the top of my module.
Option Compare Text
and it fixed my problem.
thanks
To change case in VBA, you have LCase and UCase, which will respectively change all of your string into lower case or upper case.
Here is your code with the change and got ride of the useless (and ressource-greedy) select at the end :
Sub tarheel()
LastRow = Range("A10000").End(xlUp).Row + 1
LR = Range("b10000").End(xlUp).Row + 1
IsIn = False
For r = 5 To LR
If LCase(Cells(r, 2)) = LCase(Range("b2")) Then _
MsgBox "This Item Name already exist, No shift will done": Exit Sub
Next
Cells(LastRow, 1).Value = Range("A2").Value
Cells(LastRow, 2).Value = Range("B2").Value
Cells(LastRow, 3).Value = Range("C2").Value
Range("A2:C2").ClearContents
'Range("A2").Select
End Sub
You can replace your loop that compares for existing values with a case insensitive one by forcing both values to either upper or lower case.
For r = 5 To LR
If lcase(Cells(r, 2)) = lcase(Range("b2")) Then
MsgBox "This Item Name already exist, No shift will done"
Exit Sub
end if
Next
It may be more efficient to use a case-insensitive worksheet function to check the whole range at once.
If cbool(application.countif(Range("B5:B" & LR), Cells(r, 2))) Then
MsgBox "This Item Name already exist, No shift will done"
Exit Sub
end if
Another possible:
If not iserror(application.match(Cells(r, 2), Range("B5:B" & LR), 0)) Then
MsgBox "This Item Name already exist, No shift will done"
Exit Sub
end if
Sub tarheel()
LastRow = Range("A10000").End(xlUp).Row + 1
LR = Range("b10000").End(xlUp).Row + 1
IsIn = False
For r = 5 To LR
If LCase(Cells(r, 2)) = LCase(Range("b2")) Then _
MsgBox "This Item Name already exist, No shift will done": Exit Sub
Next
Cells(LastRow, 1).Value = Range("A2").Value
Cells(LastRow, 2).Value = Range("B2").Value
Cells(LastRow, 3).Value = Range("C2").Value
Range("A2:C2").ClearContents
'Range("A2").Select
End Sub