Hi I am new of VBA programming
and I am trying to do search look up,
yes I can search single data but if the search count is >1 then I need to
do a msgbox that will appear based on how many times the string exist
and I got this result:
Yes I got the exact result but its only good for the first row of lookup
how about the next row which contains Salary: 234,871 and SSN of 241-652?
I guess I need to loop according to vlookup count but how to do it?
I need to see 2x MsgBox since it has two entries so when I click first msgbox ok
then the other one will follow .. Please help Thanks!
this is my code
Private Sub CommandButton2_Click()
On Error GoTo MyErrorHandler:
Dim E_name As String
E_name = InputBox("Enter the Employee Name :")
If Len(E_name) > 0 Then
For i = 1 To 3
Sal = Application.WorksheetFunction.VLookup(E_name, Sheets("sample").Range("B3:D8"), 3, False)
SSN = Application.WorksheetFunction.VLookup(E_name, Sheets("sample").Range("B3:D8"), 2, False)
MsgBox "Salary is : $ " & Sal & Chr(13) & "SSN is : " & SSN
Next i
Else
MsgBox ("You entered an invalid value")
End If
Exit Sub
MyErrorHandler:
If Err.Number = 1004 Then
MsgBox "Employee Not Present in the table."
End If
End Sub
This is how I would do it:
Private Sub CommandButton2_Click()
Dim E_name As String
E_name = InputBox("Enter the Employee Name :")
If Len(E_name) > 0 Then
lastRow = Range("C65000").End(xlUp).Row
For i = 2 To lastRow
If Cells(i, 2) = E_name Then
found = 1
MsgBox "Salary is : $ " & Cells(i, 4) & Chr(13) & "SSN is : " & Cells(i, 3)
End If
Next i
If found <> 1 Then MsgBox "Employee Not Present in the table."
Else
MsgBox ("You entered an invalid value")
End If
End Sub
This will also work.
Private Sub CommandButton2_Click()
Dim E_name, salary, ssn As String
Dim row As Integer
E_name = InputBox("Enter the Employee Name :")
'Set the start row
row = 3
If Len(E_name) > 0 Then
'Do until the name colum is blank
Do While Sheets("sample").Range("B" & row) <> ""
'If name are equal, show message box
If E_name = Sheets("sample").Range("B" & row) Then
salary = Sheets("sample").Range("D" & row)
ssn = Sheets("sample").Range("C" & row)
MsgBox "Salary is : $ " & salary & Chr(13) & "SSN is : " & ssn
End If
'Increase row
row = row + 1
Loop
Else
MsgBox ("You entered an invalid value")
End If
End Sub
Related
The question is how to make sure that if the entered value is empty (""), then exit the procedure, otherwise convert it to a numeric representation.
How to do it?
Sub macrotest()
Dim num As Integer
Dim text As String
num = InputBox("enter the number", "number input")
Select Case num Mod 100
Case 2, 4, 6, 8
MsgBox "even number" & num & ""
Case Else
MsgBox "idk" & num & ""
End Select
End Sub
InputBox feat. Mod
Option Explicit
Sub macrotest()
Dim cValue As Variant
Dim text As String
cValue = InputBox("enter the number", "number input")
If IsNumeric(cValue) Then
If cValue = CLng(cValue) Then ' if is whole number
If cValue Mod 2 = 0 Then
MsgBox "Even number " & cValue
Else
MsgBox "Odd number " & cValue
End If
' Select Case cValue Mod 10
' Case 0, 2, 4, 6, 8
' MsgBox "Even number " & cValue
' Case Else
' MsgBox "Odd number " & cValue
' End Select
Else
MsgBox "'" & cValue & "' is not a whole number.", _
vbExclamation, "Decimal Number"
End If
End If
End Sub
I modified your code a little to show how to test and convert user input:
Sub macrotest()
Dim num As Integer
Dim text As String
text = InputBox("enter the number", "number input")
If Not IsNumeric(text) Then Exit Sub
num = CInt(text)
Select Case num Mod 100
Case 2, 4, 6, 8
MsgBox "even number" & num & ""
Case Else
MsgBox "idk" & num & ""
End Select
End Sub
I just joined and hope to learn all I can here and contribute where I can.
I am having major issues with the last three sections of my VBA script.
The correct, incorrect, and percentage score values are not being displayed on slides 40 & 41.
On slide 42 I cannot get the textbox or the label to display the username, date and their overall percentage score.
Any help on slide 40 would be great and I can workout the rest.
**Sub shapeTextHappySmile()**strong text**
Sub ShapeTextSadSmile()
Sub CertificateBuld()**
Option Explicit
Dim UserName As String
Dim numberCorrect As Integer
Dim numberIncorrect As Integer
Dim numberPercentage As Integer
Dim numberTotal As Integer
Private Sub CertDate()
Dim Rdate As Variant
Rdate = Date
Rdate = Format((Date), "mmmm dd, yyyy")
End Sub
Sub Initialise()
numberCorrect = 12
numberIncorrect = 8
numberPercentage = 58
numberTotal = 20
numberTotal = (numberCorrect + numberIncorrect)
numberCorrect = (numberTotal - numberIncorrect)
numberIncorrect = (numberTotal - numberCorrect)
numberPercentage = Round(numberCorrect / numberTotal) * 100
End Sub
Sub TakeQuiz()
UserName = InputBox(Prompt:="Type Your Name! ")
MsgBox "Welcome To The Academic Online Tutorial Quiz " + UserName, vbApplicationModal, " Academic Online Tutorial Quiz"
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub Correct()
numberCorrect = numberCorrect + 1
MsgBox ("Great well Done! That's the correct answer")
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub Incorrect()
numberIncorrect = numberIncorrect + 1
MsgBox ("Sorry! That was the incorrect answer")
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub shapeTextHappySmile()
ActivePresentation.Slides(40).Shapes(Label1).TextFrame.TextRange.Text = 12
'numberCorrect
ActivePresentation.Slides(40).Shapes(Label2).TextFrame.TextRange.Text = numberPercentage & "%"
MsgBox "Great Job, Well done " + "," & "Please print a copy of your completion certificate"
MsgBox "After printing or saving a copy of your certificate, you can exit the presentation"
With SlideShowWindows(1).View
.GotoSlide 42
End With
End Sub
Sub ShapeTextSadSmile()
ActivePresentation.Slides(41).Shapes("AnsweredIncorrectly").TextFrame.TextRange.Text = numberIncorrect
ActivePresentation.Slides(41).Shapes("InCorrectPercentage").TextFrame.TextRange.Text = numberPercentage & " %"
MsgBox "Your score was below 70%, in order to pass the quiz and receive a certificate of completion you need to score 70% or more."
MsgBox "Please retake the quiz, and good luck"
With SlideShowWindows(1).View
.GotoSlide 1
End With
' I will add the option of redoing the entire presentation or just the quiz.
'see slide 19 action buttons
End Sub
Sub CertificateBuld()
MsgBox "Great Job, Well done " + "," & "Plese print a copy of your completion certificate"
MsgBox "After printing or saving a copy of your certificate, please exit the presentation"
If numberCorrect >= "14" Then
ActivePresentation.Slides(42).Shapes(" ABCDEFGHIJKLMN ").TextFrame.TextRange.Text = " ABCDEFGHIJKLMN "
ActivePresentation.Slides(42).Shapes("Rdate & Percentage").TextFrame.TextRange.Text = " ON " & Rdate & " WITH A SCORE OF " & numberPercentage & " %"
ActivePresentation.Slides(42).Shapes(UserName).TextFrame.TextRange.Text = UserName
'OR
If numberCorrect <= "14" Then
ActivePresentation.Slides(42).Shapes(8).TextFrame.TextRange.Text = ABCDEFGHIJKLMN "
ActivePresentation.Slides(42).Shapes(9).TextFrame.TextRange.Text = Rdate & " ON " & Rdate & " WITH A SCORE OF " & numberPercentage & " %"
ActivePresentation.Slides(42).Shapes(10).TextFrame.TextRange.Text = UserName
Else
ActivePresentation.SlideShowWindow.View.Save
ActivePresentation.SlideShowWindow.View.Exit
End If
End Sub
See comments inline:
Sub shapeTextHappySmile()
' This won't work:
'ActivePresentation.Slides(40).Shapes(Label1).TextFrame.TextRange.Text = 12
' Shapes have names that are strings, so you need to use .Shapes("Label1")
' Assuming this is an ActiveX label, you get at its properties a bit
' differently from regular PPT shapes, starting with:
' .Shapes("Label1").OLEFormat.Object
' And for a Label ActiveX control, the property you want is .Caption
' And finally, Text/Caption properties take a String value so you want to
' put the 12 in quotes or convert a numeric value to string using Cstr(x)
' Final version:
ActivePresentation.Slides(40).Shapes("Label1").OLEFormat.Object.Caption = "12"
'numberCorrect
' And make the same changes to this one:
ActivePresentation.Slides(40).Shapes(Label2).TextFrame.TextRange.Text = numberPercentage & "%"
' MsgBox "Great Job, Well done " + "," & "Please print a copy of your completion certificate"
' and I think you probably want to do this instead of the above:
MsgBox "Great Job, Well done" & ", " & "Please print a copy of your completion certificate"
MsgBox "After printing or saving a copy of your certificate, you can exit the presentation"
With SlideShowWindows(1).View
.GotoSlide 42
End With
End Sub
Instead of looking for a number greater than 6 and sending it to another sheet. I want to look up 3 names so I can search a contact list and have it pull their information from the sheet to the report sheet.
below is my old code:
Private Sub CommandButton1_Click()
Dim ws As Worksheet, myCounter
Dim erow, myValue As Long
For Each ws In Sheets
If ws.Range("C3").Value > 6 Then
myCounter = 1
ws.Select
ws.Range("c3").Select
myValue = ws.Range("C3").Value
Worksheets("Report").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1) = myValue
nextValue = MsgBox("Value found in " & ws.Name & Chr(10) & "Continue?", vbInformation + vbYesvbNo, ws.Name & " C3 = " & ws.Range("C3").Value)
Select Case nextValue
Case Is = vbYes
Case Is = vbNo
Exit Sub
End Select
End If
Next ws
If myCounter = 0 Then
MsgBox "None of the sheets contains a " & Chr(10) & "value greater than 6 in cell C3 ", vbInformation, "Not Found"
End If
End Sub
I think the third row should be String instead of Long.
The names I'm looking for are "David" "Andrea" & "Caroline", not sure if I write it three times or use a loop. Also I can't figure out how to search in the entire spreadsheet for these names.
The code below will look for the names "David", "Andrea" and "Caroline" in cell "C3" in all of the worksheets. For every match it will copy it to the first empty row in Column A in "Report" worksheet.
Note: There is no need to use Select and ActiveSheet, instead use fully qualifed Cells and Worksheets.
Code
Option Explicit
Private Sub CommandButton1_Click()
Dim ws As Worksheet, myCounter As Long
Dim erow As Long, myValue As Long
Dim nextValue As Long
For Each ws In ThisWorkbook.Sheets
With ws
Select Case .Range("C3").Value
Case "David", "Andrea", "Caroline"
myCounter = 1 ' raise flag >> found in at least 1 sheet
' get first empty row in "Report" sheet
erow = Worksheets("Report").Cells(Worksheets("Report").Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("Report").Cells(erow, 1) = .Range("C3").Value
nextValue = MsgBox("Value found in " & .Name & Chr(10) & "Continue?", vbInformation + vbYesNo, .Name & " C3 = " & .Range("C3").Value)
Select Case nextValue
Case Is = vbYes ' <-- if you are not doing anything here, you don't need it >> maybe you don't need the entire `Select Case` here
Case Is = vbNo
Exit Sub
End Select
End Select ' Select Case .Range("C3").Value
End With
Next ws
If myCounter = 0 Then
MsgBox "None of the sheets contains the names " & Chr(10) & " 'David', 'Andrea', 'Caroline' in cell C3 ", vbInformation, "Not Found"
End If
End Sub
Comment: It seems you are not doing anything in the case of Case Is = vbYes in the Select Case below:
nextValue = MsgBox("Value found in " & .Name & Chr(10) & "Continue?", vbInformation + vbYesNo, .Name & " C3 = " & .Range("C3").Value)
Select Case nextValue
Case Is = vbYes ' <-- if you are not doing anything here, you don't need it >> maybe you don't need the entire `Select Case` here
Case Is = vbNo
Exit Sub
End Select
You can replace the entire thing with :
If MsgBox("Value found in " & .Name & Chr(10) & "Continue?", vbInformation + vbYesNo, .Name & " C3 = " & .Range("C3").Value) = vbNo Then
Exit Sub
End If
I've been looking to write a macro to check 3 columns to ensure the contents are a date value. The columns can contain empty cells.
The below returns a message box for each cell that is not a date, even the blanks.
Sub DateCheck()
With ActiveSheet
lastRow = .Range("AB" & Rows.Count).End(xlUp).Row
For RowCount = 2 To lastRow
POC = .Range("AB" & RowCount)
If Not IsDate(POC) Then
MsgBox ("Please enter valid date in Cell : AB" & RowCount & ". Example: dd/mm/yyyy")
End If
Next RowCount
End With
End Sub
Could anybody be so kind as to help to adjust this to look at 3 non-adjacent columns, ignore blank cells and only return one message per column in the event it finds non-date values?
Thanks as always
Chris
Code:
Sub DateCheck()
Dim s(2) As String
Dim i As Integer
Dim o As String
Dim lastRow As Long
Dim r As Long
'Enter columns here:
s(0) = "A"
s(1) = "B"
s(2) = "C"
For i = 0 To 2
With ActiveSheet
lastRow = .Range(s(i) & Rows.Count).End(xlUp).Row
For r = 2 To lastRow
POC = .Range(s(i) & r)
If Not IsDate(POC) Then
o = o & ", " & .Range(s(i) & r).Address
End If
Next r
MsgBox ("Please enter valid date in Cells : " & Right(o, Len(o) - 1) & ". Example: dd/mm/yyyy")
o = ""
End With
Next i
End Sub
I would change your loop to a For Each In ... Next and use .Union to construct a range of non-adjacent columns.
Sub MultiDateCheck()
Dim lr As Long, cl As Range, rng As Range, mssg As String
With ActiveSheet
lr = .Range("AB" & Rows.Count).End(xlUp).Row
Set rng = Union(.Range("AB2:AB" & lr), .Range("AM2:AM" & lr), .Range("AZ2:AZ" & lr))
For Each cl In rng
If Not IsDate(cl.Value) And Not IsEmpty(cl) Then _
mssg = mssg & cl.Address(0, 0) & Space(4)
Next cl
End With
If CBool(Len(mssg)) Then
MsgBox ("Please enter valid date(s) in Cell(s): " & Chr(10) & Chr(10) & _
mssg & Chr(10) & Chr(10) & _
"Example: dd/mm/yyyy")
Else
MsgBox "All dates completed!"
End If
Set rng = Nothing
End Sub
I've used a single lastrow from column AB to determined the scope of the cells to be examined but individual rows for each column could easily be compensated for.
Addendum: Code modified for a single message showing rogue non-date/non-blank cells (as below). The Chr(10) is simply a line feed character.
I have a workbook called Open Case Report.xlsm with the sheets called RAW_Data and Formatted.
I want to create a macro that will search RAW_Data for a set of 2 names in column E and copy the entire row over to Formatted in a specific spot such as A1.
I have looked on here and found a few codes that are similar, but I can't seem to adapt the code to do what I want without getting a debug error.
You can spot a value using the MATCH method. After that, you can use that Rw to transfer data to another sheet:
Sub FindRowTransferData()
Dim Rw As Long, myVAL As String
myVAL = Application.InputBox("Enter search value:", "Search", "John Doe", Type:=2)
If myVAL = "False" Then Exit Sub
On Error Resume Next
Rw = Application.WorksheetFunction.Match(myVAL, Sheets("RAW_Data").Range("E:E"), 0)
On Error Goto 0
If Rw = 0 Then
MsgBox "The search value '" & myVAL & "' was not found"
Exit Sub
End If
'MsgBox "The search value '" & myVAL & "' was found on row: " & Rw
With Sheets("Formatted")
.Range("B3").Value = Sheets("RAW_Data").Range("A" & Rw).Value 'name
.Range("B4").Value = Sheets("RAW_Data").Range("B" & Rw).Value 'address
.Range("C3").Value = Sheets("RAW_Data").Range("C" & Rw).Value 'phone
'etc....
End With
End Sub
Based on the comments below, these suggested edits:
Rw = Application.WorksheetFunction.Match(myVAL, Sheets("RAW_Data").Range("F:F"), 0)
On Error Goto 0
If Rw = 0 Then
MsgBox "The search value '" & myVAL & "' was not found"
Exit Sub
End If
'MsgBox "The search value '" & myVAL & "' was found on row: " & Rw
Sheets("RAW_Data").Rows(Rw).Copy Sheets("Formatted").Range("A" & Rows.Count).End(xlUp).Offset(1)