User enters the Waypoint id and then press delete record it, so data of that particular waypoint id should be delete from observations table.
Written a subroutine where my vba code first find the waypoint id in the observation worksheet, get the row number and then delete the row number and move the cell up. If it doesnot find the waypoint id then message should appear Waypoint id not found and cannot be deleted.
My vba code is not working. Can anyone help me to fix this issue? Attach File with name Problem.xlsm
Sub FindRecord(WyPt)
Dim Value As String
WyPtRow = 0
ReadRow = 2
Value = Cells(ReadRow, 2).Select 'Observation Sheet-WayPointID
While Value <> ""
If WyPt = Value Then
WyPtRow = ReadRow
Exit Sub
End If
ReadRow = ReadRow + 1
Value = Cells(ReadRow, 2)
Wend
End Sub
Sub DeleteRecord()
Set DEFrm = Sheets("DataEntryForm")
Set ObsData = Sheets("Observations")
WyPt = Trim(DEFrm.Cells(6, 2)) 'DataEntryForm worksheet-WayPointID
Call FindRecord(WyPt)
If WyPtRow > 0 Then
Worksheets("Observations").Rows(WyPtRow).Delete Shift:=xlShiftUp
MsgBox "WaypointID found", vbOKOnly + vbCritical, "Deleted Succesfully"
End If
If WyPtRow = 0 Then
MsgBox "WaypointID Not found", vbOKOnly + vbCritical, "We can't delete the record"
Exit Sub
End If
End Sub
I suggest you use application.match to find the row to delete.
I have not downloaded your file so this may need to adjustments.
Sub FindRecord()
Set DEFrm = Sheets("DataEntryForm")
WyPt = Trim(DEFrm.Cells(6, 2).value)
WyPtRow = application.match(WyPt, range("B:B"),0)
if not iserror(WyPtRow) then
DeleteRecord(WyPtRow)
else
msgbox "No waypoint found"
end if
End sub
Sub DeleteRecord(WyPtRow)
Worksheets("Observations").Rows(WyPtRow).EntireRow.Delete
End sub
Edit sorry I see now that I made the code in reverse.
My idea was to call FindRecord and it calls delete, I see now that you called Delete and it called find.
Try this code.
Sub DelRow(WyPt As String)
Dim i As Long
For i = 2 To 65536
If Cells(i, 2).Text = WyPt Then
Worksheets("Observations").Rows(i).Delete Shift:=xlShiftUp
MsgBox "WaypointID found", vbOKOnly + vbCritical, "Deleted Succesfully"
Exit Sub
End If
If Cells(i, 2).Text = "" Then 'stop on first empty row
Exit For
End If
Next
MsgBox "WaypointID Not found", vbOKOnly + vbCritical, "We can't delete the record"
End Sub
Related
Excel VB newbie. I know I must be missing something very simple. How do I get before_save event to work with more than one worksheet? Only one needs code. I have it in ThisWorkbook. It works if I only have one sheet in my workbook.
After seeing the comment that it doesn't matter if there's more than one worksheet I looked again at my code. I fixed the code and now the BeforeSave event will trigger and not save until all conditions are met like it's supposed to.
The BeforeSave event triggers if I put it in ThisWorkbook. But if I put it in Sheet1 and call the sub in ThisWorkbook, it still runs the sub like it's supposed to but doesn't prevent it from saving. Hoping this makes sense. I know the code is messy so please bear with me.
Sheet1:
Sub checkSheet1()
Dim cellCount As Variant, findEmpty As String, Counter%
allYellowCellsArray = Array(Range("C6"), Range("C7"), Range("C8"), Range("C9"), Range("C18"), Range("C19"), Range("C20"), Range("C21"), Range("C22"), Range("C29"), Range("C30"), Range("C31"), Range("C32"), Range("C33"), Range("C42"), Range("C62"))
noDateYellowCellsArray = Array(Range("C6"), Range("C7"), Range("C8"), Range("C9"), Range("C18"), Range("C19"), Range("C20"), Range("C21"), Range("C22"), Range("C29"), Range("C30"), Range("C31"), Range("C32"), Range("C33"), Range("C42"))
emptyCell = ""
Counter = 0
Debug.Print vbNewLine & "List the values of each cell in the array:"
'count number of yellow/empty cells
For Each cellCount In allYellowCellsArray
Debug.Print cellCount.Address() & " value is " & cellCount & " and color is " & cellCount.DisplayFormat.Interior.Color
If cellCount = emptyCell Then
Counter = Counter + 1
End If
Next
'If-Then statements to alert how many yellow cells are still empty.
If Counter >= 1 Then
MsgBox "(" & Counter & ") Mandatory Cells Have Not Been Completed", vbExclamation, "Missing Information"
'cellCount = "Enter Missing Information"
End If
For Each cellCount In noDateYellowCellsArray
If cellCount.Value = "" Then
cellCount.Value = "Enter Missing Information"
End If
Next
'Evaluate all yellow cells to prevent empty cells and make sure the set values have been changed ----
Dim cellValue As Variant
Dim fieldsAreYellow As Boolean
fieldsAreYellow = True
Dim redCellColor As Boolean
redCellColor = True
Dim cellCellColor As Variant
Debug.Print vbNewLine & "List cells that are red:"
For Each cellCellColor In allYellowCellsArray 'check for red cells
If cellCellColor.DisplayFormat.Interior.Color = 255 Then 'if cell background color is red
redCellColor = True
Debug.Print cellCellColor.Address() & " is " & cellCellColor.DisplayFormat.Interior.Color
Cancel = True
End If
If redCellColor = False Then
MsgBox "There are no more red cells."
Cancel = True
End If
Next cellCellColor
Dim cellCountRedCells As Variant, redCellCounter%
redCellCounter = 0
For Each cellCountRedCells In allYellowCellsArray
If cellCountRedCells.DisplayFormat.Interior.Color = 255 Then 'red
redCellCounter = redCellCounter + 1
Debug.Print "redCellCounter is " & redCellCounter
'MsgBox "redCellCounter is " & redCellCounter
End If
Next
Debug.Print "redCellCounter is " & redCellCounter
'Check to see if cells in array have been changed
Debug.Print vbNewLine & "List the current background color of the first non-numeric cell that stopped the loop:"
For Each cellValue In allYellowCellsArray
If cellValue = "Enter Missing Information" Then
Debug.Print vbNewLine & cellValue
fieldsAreYellow = False
Debug.Print cellValue.Address() & " color is " & cellValue.DisplayFormat.Interior.Color
MsgBox "Check all of your cells for correct information." & vbNewLine & "There are still (" & redCellCounter & ") red cells.", vbCritical, "SAVE CANCELLED"
Cancel = True ' ** prevent the file from being saved **
Exit For
End If
Next cellValue
'Final check
If (fieldsAreYellow = True) And (redCellCounter = 0) Then
MsgBox "The document will be saved." & vbNewLine & "Remember the naming convention." & vbNewLine & "Customer_PIP Seal Calculator_Part Number rev#_Part Name_DDMMYY", vbInformation, "Good to Go!"
Cancel = False 'allow save
Else:
MsgBox "This file will not save until all of the cells have correct information.", vbCritical, "SAVE CANCELLED"
Cancel = True 'cancel save
End If
End Sub
ThisWorkbook:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Call Sheet1.checkSheet1
End Sub
I created a new excel file and tested this event. It works perfectly on both sheets.
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
MsgBox "OK"
End Sub
I suggest to try this on a new file and then copy your code to the new file.
In order to make the event was as you need, the called Sub must be transformed in a Function returning Boolean.
The event code should look like this:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Cancel = Sheet1.checkSheet1
End Sub
And the called function, like this:
Public Function checkSheet1() As Boolean
If 1 = 1 Then
MsgBox "The saving cannot take place..."
checkSheet1 = True 'instead of Cancel = True in the Sub
Else
checkSheet1 = False
End If
End Function
You must adapt your code to finally return something like checkSheet1 = Cancel. But take care to properly declare Dim Cancel as Boolean...
If something unclear, please, do not hesitate to ask for clarifications. If you need me to transform your existing Sub, I can do it, but I think it is better for you do do that, in order to understand the meaning and learn...
Loop Through Worksheets In BeforeSave
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
' Create a list of worksheet names.
Const wsList As String = "Sheet1,Sheet2,Sheet3"
Dim nms() As String ' Declare an array of type 'String'.
nms = Split(wsList, ",") ' Write the list to the array.
Dim ws As Worksheet ' Declare a worksheet variable.
Dim n As Long ' Declare a 'counter' variable of type 'Long'.
' Loop through the elements (names) in the array.
For n = 0 To UBound(nms)
' Define current worksheet.
Set ws = ThisWorkbook.Worksheets(nms(n))
' Do something, e.g. write some text to cell 'A1' and autofit column 'A'.
ws.Range("A1").Value = "Testing worksheet '" & ws.Name & "'."
ws.Columns("A").AutoFit
Next n
End Sub
I'm creating a simple log that will update a table of devices to show when the last firmware update was and who updated it. I have a form that will update a single device entry correctly, but I can't get it to work with multiselect. It will only update the last item in the list.
How can I get it so that a that someone can update multiple entries with their name and date in a single use of the form? I think I need to loop through the selected index values (for loop?), but I'm just not seeing it.
Private Sub UpdateButton_Click()
EditIndex = Me.UpdateDevice.ListIndex
If EditIndex = -1 Then
MsgBox "No device was selected", vbExclamation, "Update Log"
Else
EditIndex = EditIndex + 2
Devices.Range("F" & EditIndex) = Me.DateUpdated
Devices.Range("G" & EditIndex) = Me.UpdatedBy
Unload Me
End If
MsgBox "Log has been successfully updated", vbExclamation, "Update Log"
End Sub
EditIndex is a public variable I have saved in a module to use across various forms in this file.
Private Sub UpdateButton_Click()
EditIndex = Me.UpdateDevice.ListIndex
Dim i As Integer
Dim rmaster As Long
If EditIndex = -1 Then
MsgBox "No device was selected", vbExclamation, "Update Log"
Exit Sub
Else
For i = 0 To Me.UpdateDevice.ListCount - 1
If Me.UpdateDevice.Selected(i) Then
rmaster = i + 2
Devices.Range("F" & rmaster) = Me.DateUpdated.Value
Devices.Range("G" & rmaster) = Me.UpdatedBy.Value
Debug.Print (Me.UpdateDevice.List(i))
Debug.Print rmaster
Else
End If
Next i
Unload Me
End If
MsgBox "Log has been successfully updated", vbExclamation, "Update Log"
End Sub
I kept the debug.print to see if it was returning correctly. Only returns the first selected item if I try to update the columns.
ListBox to Update Worksheet
ListIndex will return -1 only if the list box is empty (not populated).
Objects
Command Button - UpdateButton
List Box - UpdateDevice
Text Box - DateUpdated
Text Box - UpdatedBy
Worksheet - Devices
All controls are on a user form.
Devices is the code name of the worksheet.
The Code
Option Explicit
Private Sub UpdateButton_Click()
Dim ItemsCount As Long
Dim i As Long
With Me.UpdateDevice
For i = 0 To .ListCount - 1
If .Selected(i) Then
ItemsCount = ItemsCount + 1
EditIndex = i + 2 ' EditIndex is maybe not needed!?
Devices.Range("F" & EditIndex) = Me.DateUpdated
Devices.Range("G" & EditIndex) = Me.UpdatedBy
End If
Next i
End With
' I don't know why, but I needed the following line to see the complete
' change in worksheet 'Devices' (CodeName) before the MsgBox:
'Application.ScreenUpdating = True
Select Case ItemsCount
Case 0
MsgBox "No device was selected", vbExclamation, "Update Log"
Case 1
MsgBox "Log has been successfully updated with 1" _
& " entry.", vbInformation, "Update Log"
Case Else
MsgBox "Log has been successfully updated with " & ItemsCount _
& " entries.", vbInformation, "Update Log"
End Select
Unload Me
End Sub
The .ListIndex property only returns the index of the last selected item from a multiselect enabled listbox control. You'll have to iterate though all the items in the list and check to see if they have been selected. Note that .ListCount returns the number of items in the listbox control starting with 1 while the .Selected(i) references the list index values which start at 0. (i.e. if the listbox has one item in it, .ListCount returns 1 while .ListIndex returns 0 because there is 1 item in the list, but it is the item at the 0th index).
For i = 0 To Me.lsBox.ListCount - 1
If Me.lsBox.Selected(i) Then
'record was selected
'do something
Debug.Print (Me.lsBox.List(i))
Else
'record was not selected
'do nothing
End If
Next i
Edit 1 - In action
Edit 2 - OPs updated code exactly
When I on the step F8 click. then say it Goto is not defined. I try to make a inputbox with a messagebox that me the answer give. And I try also to make code when the values not correct is. See, you where I make a mistake in my VBA code:
Sub TwoNumbersinputbox()
Dim bytAnswer1 As String
Dim bytAntwer2 As String
Dim Range As Byte
Dim strNumber1 As String
Dim strNumber2 As String
[C3] = "Number1"
[C4] = "Number2"
Start1:
strNumber1 = InputBox("Give number one?", "Invoer", 5, 567, 567)
If IsNumeric(strNumber1) Then
MsgBox "This must be Number1", vbCritical, _
"Number1 input"
GoTo strNumber1
Else: [B2] = strNumber1
End If
If Not IsNumeric(strNumber1) Then
MsgBox "there is error.", vbCritical, "Number2 input"
bytAnwer1 = MsgBox("Start Again?", vbYesNo)
If bytAnwer1 = vbYes Then GoTo Start
End If
Start2:
strGetal2 = InputBox("Give Number2?", "Input", 5, 567, 567)
If IsNumeric(strNumber2) Then
MsgBox "This must be Number2 ", vbCritical, _
"Number2 input"
GoTo strNumber2
Else: [B3] = strNumber2
End If
If Not IsNumeric(strGetal2) Then
MsgBox "Is there an error.", vbCritical, "Number2 input"
bytAnswer2 = MsgBox("Start Again?", vbYesNo)
If bytAnswer2 = vbYes Then GoTo Start
End If
End Sub
First thing first - never use GOTO. Only in error handling (On Error statement (VBA)).
Second - if you need to use it, a mark is needed. E.g., if it is GoTo somewhere, then in the code it should be defined like this - somewhere:.
Sub DontUseGoTo()
Dim i As Long
i = 0
somewhere:
i = i + 1
Debug.Print i
If i < 10 Then
GoTo somewhere
End If
End Sub
I've been tasked to correct someones code in VBA. I've never VBA programmed before so this is very basic.
Am I correct in assuming that after the first Then it checks if the next condition is true and thats where it executes the last line?
If data.Cells(i, 3 + 4).Value <> "" Then
If data.Cells(i, 2 + y).Value <> "" Then
tilqa = data.Cells(i, 2 + y)
End If
Whenever you have a question about the functioning of a code, try to write a small example, like the one below, with MsgBox(), showing exactly what is happening. The 1=1 and 2=2 is always evaluated to True:
Sub TestMe()
If 1 = 1 Then
If 2 = 2 Then
MsgBox "First check here!"
Else
MsgBox "This is not checked!"
End If
MsgBox "Then check here!"
End If
End Sub
Amd this is how the If-Else-End If may function without Else:
Sub TestMe()
If 1 = 1 Then
If 2 = 2 Then
MsgBox "First check here!"
End If
MsgBox "Then check here!"
End If
End Sub
I really searched hours and hours, but I can't find any solutions.
You should only enter numbers into the Inputbox and a msgbox should sppears when you just hit ok without any number or string...
The first part was easy, but I always get an error message by just hitting OK!
Public Sub test()
Dim vntReturn As Variant
vntReturn = Application.InputBox("Bitte Wert eingeben", "Eingabe", , , , , , 1)
If StrPtr(vntReturn) = 0 Then
MsgBox "Abbrechen gedrückt"
Else
If vntReturn = False Then
MsgBox "Nix eingegeben"
Else
MsgBox vntReturn
End If
End If
End Sub
This is happening because you're declaring the Type for this InputBox to a number. So excel will automatically try to correct this. You can use an InputBox without a Type and program your own verification for checking if it's an integer or not.
Otherwise you can also add this before your code:
Application.DisplayAlerts = False
And then set it to True after. Now when you hit ok you won't be prompted with the error, but the InputBox will not go away. You could add additional instructions to the InputBox to make it clear it needs a number.
#mehow: as Alex D just said: Your answers are similar ;-)
First I used the code of mehow, but now I just create a userform with only an "OK-button".
Private Sub Rechnen_Click()
Dim i As Integer ' Variable deklarieren
Dim Sum As Integer
Dim counter As Variant
i = 0 ' deklariert, löst beim Kompilieren keinen Fehler aus
Sum = 0 ' nicht deklarierte Variable löst beim Kompilieren einen Fehler aus
counter = TextBox1.Value
Application.DisplayAlerts = False
If Not IsNumeric(counter) Then
Exit Sub
Else
Unload Userform1
On Error Resume Next
Do Until i >= counter
Zahl = InputBox("Pls enter a number:", i + 1 & ". Versuch")
Sum = Sum + Zahl
i = i + 1
If Not IsNumeric(Zahl) Then
MsgBox "calculation premature cancelled!"
Exit Do
End If
Loop
Ausgabe = MsgBox("Die Summe lautet: " & Sum, vbInformation, "Ergebnis")
Question = MsgBox("is it enough?", vbYesNo + vbQuestion, "repeat")
If Question = vbNo Then
Userform1.Show
Else
Unload Userform1
Exit Sub
End If
End If
End Sub
and so the userform looks like:
Now the program works fine ;) Thank you guys!