Excel vba username/ password lookup - vba

Private Sub cmdLogin_Click()
On Error GoTo ErrorHandler
Dim RowNo As Long
Dim Id As String
Dim pw As String
Dim ws As Worksheets
Application.ScreenUpdating = False
Set ws = Worksheets("User&Pass")
Id = LCase(Me.txtLogin)
RowNo = Application.WorksheetFunction.Match(Id, ws.range("A2:A999"), 0)
CleanExit:
Set ws = Nothing ' free memory
Application.ScreenUpdating = True ' turn on the screen updating
Exit Sub
ErrorHandler:
MsgBox "Unable to match ID, enter valid ID.", vbOKOnly
GoTo CleanExit
End Sub
I've got an excel userform i've been working on and now I need it to look more professional by having a log-in screen. I've started with the code above but I have come to a dead end.
how its set up my aim is to say if id & password matches then load up workbook or unhide the workbook and continue. the username and password are on a sheet called "User&Pass"
Aim is it reads from there in columns a- user / b- pw respectively and if it's a success I will hide that sheet so they cant see other user's information
with what I started above I just need it to say if it matches usercolumn then corresponding pw next door to it continue else go to my errorhandler
i can do the formatting about hiding and unhiding sheets etc just need help with reading username and pw
thanks very much in advance
Z
Editted attempt one;
Private Sub cmdLogin_Click()
On Error GoTo ErrorHandler
Dim RowNo As Long
Dim Id As String
Dim pw As String
Dim ws As Worksheets
Application.ScreenUpdating = False
Set ws = Worksheets("User&Pass")
Id = LCase(Me.txtLogin)
RowNo = Application.WorksheetFunction.Match(Id, ws.range("A2:A999"), 0)
RowNo = RowNo + 1
pw = ws.range("B" & RowNo)
If pw = Me.txtLogin Then
'continue
txt1.Value = "yes"
Else
GoTo ErrorHandler
End If
CleanExit:
Set ws = Nothing ' free memory
Application.ScreenUpdating = True ' turn on the screen updating
Exit Sub
ErrorHandler:
MsgBox "Unable to match ID, enter valid ID.", vbOKOnly
GoTo CleanExit
End Sub
#siddarthRout
Private Sub cmdLogin_Click()
Dim RowNo As Long
Dim Id As String, pw As String
Dim ws As Worksheet
Dim aCell As range
On Error GoTo ErrorHandler
Application.ScreenUpdating = True
Set ws = Worksheets("Details")
Id = LCase(Me.txtLogin)
Set aCell = ws.Columns(1).Find(What:=Id, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'~~> If match found
If Not aCell Is Nothing Then
RowNo = aCell.Row
'~~> Rest of your code. For example if the password is
'~~> Stored in Col B then
Debug.Print aCell.Offset(, 1)
Unload Me
FrmMenu.Show
'~~> You can then use the above aCell.Offset(, 1) to
'~~> match the password which the user entered
Else '<~~ If not found
MsgBox "Unable to match ID, enter valid ID.", vbOKOnly
End If
CleanExit:
Set ws = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox Err.Description
Resume CleanExit
End Sub

TESTED AND TRIED
Is this what you are trying?
CODE
Option Explicit
Private Sub cmdLogin_Click()
Dim RowNo As Long
Dim Id As String, pw As String
Dim ws As Worksheet
Dim aCell As Range
On Error GoTo ErrorHandler
If Len(Trim(txtLogin)) = 0 Then
txtLogin.SetFocus
MsgBox "Username cannot be empty"
Exit Sub
End If
If Len(Trim(txtPassword)) = 0 Then
txtPassword.SetFocus
MsgBox "Password cannot be empty"
Exit Sub
End If
Application.ScreenUpdating = False
Set ws = Worksheets("User&Pass")
Id = LCase(Me.txtLogin)
Set aCell = ws.Columns(1).Find(What:=Id, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'~~> If match found
If Not aCell Is Nothing Then
RowNo = aCell.Row
If Me.txtPassword = aCell.Offset(, 1) Then
FrmMenu.Show
Unload Me
Else
MsgBox "Unable to match UserID or PasswordID, Please try again", vbOKOnly
End If
Else '<~~ If not found
MsgBox "Unable to match UserID or PasswordID, Please try again", vbOKOnly
End If
CleanExit:
Set ws = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox Err.Description
Resume CleanExit
End Sub
TIP:
Never let your user know (from security perspective) what was incorrect - The username or the password. Always show a generic message like "Unable to match UserID or PasswordID, Please try again" :)
HTH
Sid

Another way
On Error Resume Next
If Me.password <> Application.VLookup(Me.username, Sheet1.Cells(1, 1).CurrentRegion, 2, False) Then
MsgBox ("incorrect")
Exit Sub
Else
MsgBox ("Correct Password Entered")
End If
Also you will need to make sure that all your sheets are xlSheetVeryHidden from the outset to combat having macros disabled and un-hide them as part of your successful log in routine. You'll also want to set a password on your VBA project to prevent people unhiding the sheets. Bear in mind however, Excel is about as secure as a wet paper bag ;)

Related

Embed Chart Template into Macro

I am trying to embed applying a chart template into a macro and require help.
I have this code for the Macro that I am using to create scatter plots:
Option Explicit
Public Sub Test()
' Keyboard Shortcut: Ctrl+Shift+X
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1") 'change as appropriate
Application.ScreenUpdating = False
BuildChart ws, SelectRanges(ws)
Application.ScreenUpdating = True
End Sub
Private Function SelectRanges(ByRef ws As Worksheet) As Range
Dim rngX As Range
Dim rngY As Range
ws.Activate
Application.DisplayAlerts = False
On Error Resume Next
Set rngX = Application.InputBox("Please select X values. One column.",
Type:=8)
If rngX Is Nothing Then GoTo InvalidSelection
Set rngY = Application.InputBox("Please select Y values. One column.",
Type:=8)
If rngY Is Nothing Then GoTo InvalidSelection
If rngX.Columns.Count > 1 Or rngY.Columns.Count > 1 Then GoTo
InvalidSelection
On Error GoTo 0
Set SelectRanges = Union(rngX, rngY)
Application.DisplayAlerts = True
Exit Function
InvalidSelection:
If rngX Is Nothing Or rngY Is Nothing Then
MsgBox "Please ensure you have selected both X and Y ranges."
ElseIf rngX.Rows.Count <> rngX.Rows.Count Then
MsgBox "Please ensure the same number of rows are selected for X and Y
ranges"
ElseIf rngX.Columns.Count > 1 Or rngY.Columns.Count > 1 Then
MsgBox "Please ensure X range has only one column and Y range has only
one column"
Else
MsgBox "Unspecified"
End If
Application.DisplayAlerts = True
End
End Function
Private Sub BuildChart(ByRef ws As Worksheet, ByRef unionRng As Range)
With ws.Shapes.AddChart2(240, xlXYScatter).Chart
.SetSourceData Source:=unionRng
End With
ActiveChart.ApplyChartTemplate ( _
"C:\Users\maaro\AppData\Roaming\Microsoft\Templates\Charts\1.crtx")
End Sub
And would like to embed this code below into the above code so that it applies the template to the chart I create whenever I run this Macro. My initial guess would be to put it underneath "Private Sub BuildCharts". How would I be able to do this? Thank you.
ActiveChart.ApplyChartTemplate ( _
"C:\Users\XXXXX\AppData\Roaming\Microsoft\Templates\Charts\1.crtx")
Perhaps modify Sub BuildChart like this:
Private Sub BuildChart(ByRef ws As Worksheet, ByRef unionRng As Range)
With ws.Shapes.AddChart2(240, xlXYScatter).Chart
.SetSourceData Source:=unionRng
.ApplyChartTemplate ( _
"C:\Users\maaro\AppData\Roaming\Microsoft\Templates\Charts\1.crtx")
End With
End Sub

Code to allow user make range selection to search list in another workbook and return cell value

Info
Workbook A: Has a master worksheet with a list of items, but the values are arranged in month columns
Workbook B: I have two sheets with different list of items I want to use to search Workbook A and return the current or specific month I need.
Note: Workbook B columns is offset, so we may need to account for this.
The code I have so far:
Sub Button()
Dim OpenFileName As String
Dim MyWB As Workbook, wb As Workbook
Dim aRange As Range
'Excel titled, "MODs", contains this module
Set MyWB = ThisWorkbook
'Ignore possible messages on a excel that has links
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
'Select and Open workbook
OpenFileName = Application.GetOpenFilename '("clients saved spreadsheet,*.xlsb")
If OpenFileName = "False" Then Exit Sub
Set wb = Workbooks.Open(OpenFileName)
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
If MsgBox("Please select list range to search.", vbExclamation, "Search List") = vbOK Then
On Error Resume Next
Set aRange = Application.InputBox(prompt:="Enter range", Type:=8)
If aRange Is Nothing Then
MsgBox "Operation Cancelled"
Else
aRange.Select
End If
End If
End Sub
I might might be making this harder than I should be, so I am open to suggestions. I can't seem to find the right find function to use my selected range list and target the newly open workbook with the specific master worksheet (something similar to a vlookup).
Version 2: with a set range but I'm still getting not value returns
Sub Button()
Dim OpenFileName As String
Dim MyWB As Workbook, wb As Workbook
Dim MyWs As Worksheet, ws As Worksheet
Dim aRange As Range
'This line of code turns off the screen updates which make the macro run much faster.
'Application.ScreenUpdating = False
'Excel titled, "MODs", contains this module
Set MyWB = ThisWorkbook
Set MyWs = MyWB.Sheets("Sheet")
'Ignore possible messages on a excel that has links
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
'Select and Open workbook
OpenFileName = Application.GetOpenFilename '("clients saved spreadsheet,*.xlsb")
If OpenFileName = "False" Then Exit Sub
Set wb = Workbooks.Open(OpenFileName)
On Error Resume Next
Set ws = Application.InputBox("Select a cell on the key sheet.", Type:=8).Parent
On Error GoTo 0
If ws Is Nothing Then
MsgBox "cancelled"
Else
MsgBox "You selected sheet " & ws.Name
End If
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
With MyWs
For Each aCell In .Range("A1:A10" & LastRow)
If Len(Trim(.Range("A19" & aCell.Row).Value)) <> 0 Then
.Cells(aCell.Row, 15) = Application.WorksheetFunction.VLookup( _
aCell.Value, ws.Range("A1:C18"), 2, 0)
End If
Next aCell
End With
'wb.Close (False)
'If MsgBox("Please select list range to search.", vbExclamation, "Search List") = vbOK Then
'On Error Resume Next
'Set aRange = Application.InputBox(prompt:="Enter range", Type:=8)
'If aRange Is Nothing Then
'MsgBox "Operation Cancelled"
'Else
'aRange.Select
'End If
'End If
'Return to default setting of screen updating.
'Application.ScreenUpdating = True
End Sub
I think the problem I'm running into is this code:
With MyWs
For Each aCell In .Range("A1:A10" & LastRow)
If Len(Trim(.Range("A19" & aCell.Row).Value)) <> 0 Then
.Cells(aCell.Row, 15) = Application.WorksheetFunction.VLookup( _
aCell.Value, ws.Range("A1:C18"), 2, 0)
begin declaringaCell as Range and lastRow as long
You seem to miss the definition of lastRow, which could be something like
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
then look carefully at .Range("A1:A10" & LastRow). Assume lastRow were 100 then this would set a range from A1 to A10100: is that what you want? Or may be you'd use
.Range("A1:A" & lastRow)
again .Range("A19" & aCell.Row) would lead to a single cell address such as "A1989" (were aCell.Row = 89): is that what you want?
other than what above I can't grasp the actual scenario of what you're searching where. You may want to provide more info about that

Create new sheets based on a list

When I create new sheets based on the below VBA Code, it works as I want, but there is a small problem. The issue is that when creating all the sheets based on the list given in Column ("A"), it create one more sheet with the same name of the original one and also show an error in the code in this section
ActiveSheet.Name = c.Value
Any assistant to correct.
Private Sub CommandButton1_Click()
On Error Resume Next
Application.EnableEvents = False
Dim bottomA As Integer
bottomA = Range("A" & Rows.Count).End(xlUp).Row
Dim c As Range
Dim ws As Worksheet
For Each c In Range("A2:A" & bottomA)
Set ws = Nothing
On Error Resume Next
Set ws = Worksheets(c.Value)
On Error GoTo 0
If ws Is Nothing Then
Sheets("Format").Select
Sheets("Format").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = c.Value
End If
Next
Application.EnableEvents = True
End Sub
I think you forgot in your For statement to state which worksheet the range will be on. So that line should be something like this:
For Each c in worksheet(1).Range("A2:A" & bottomA)
Also there other issue in your code, I just made quick re-write..
Private Sub CommandButton1_Click()
Dim c As Range
Dim ws As Worksheet
Dim bottomA As Integer
On Error GoTo eh
Application.EnableEvents = False
bottomA = Range("A" & Rows.Count).End(xlUp).Row
For Each c In Worksheets(1).Range("A2:A" & bottomA)
'Set ws = Nothing
'On Error Resume Next
'Set ws = Worksheets(c.Value)
'On Error GoTo 0
'If ws Is Nothing Then
Sheets("Format").Select
Sheets("Format").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = c.Value
'End If
Next
Application.EnableEvents = True
Exit Sub
eh:
Debug.Print ""
Debug.Print Err.Description
MsgBox (Err.Description)
End Sub
Try to be explicit as much as possible.
Private Sub CommandButton1_Click()
On Error GoTo halt ' Do not use OERN, that ignores the error
Application.EnableEvents = False
Dim bottomA As Long
' explicitly work on the target sheet
With Sheets("SheetName")
bottomA = .Range("A" & .Rows.Count).End(xlUp).Row
Dim c As Range, ws As Worksheet, wb As Workbook
' explicitly define which workbook your working on
Set wb = ThisWorkbook
For Each c In .Range("A2:A" & bottomA)
On Error Resume Next
Set ws = wb.Sheets(c.Value)
On Error GoTo 0
If ws Is Nothing Then
wb.Sheets("Sheet1").Copy _
After:=wb.Sheets(wb.Sheets.Count)
ActiveSheet.Name = c.Value
End If
Next
End With
forward:
Application.EnableEvents = True
Exit Sub
halt:
MsgBox Err.Number
Resume forward
End Sub
I don't know why you need to turn events On/Off (I don't see it required at least for your example). Nonetheless, I replaced the On Error Resume Next with a more flexible error handling routine because what you did is simply ignoring any errors. Check this out as well to improve how you work with objects and avoid unnecessary use of Active[object] and Select.

FindNext from InputBox throughout Workbook

Noob here. I've found plenty of code on this site and want to say thanks to all those who contribute.
My question is I have a UserForm. I click a button to bring up an InputBox, where they enter a value to search for bank name, banker name, business name, etc.
I have the code to do the search no problem, but I want to be able to be able to continue to search all of the instances of the InputBox value. For example, searching for the name "Smith" and if the first one isn't the one I need, to continue the search until I've landed on the one I'm looking for.
Dim ws As Worksheet
Dim rFound As Range
Dim strName As String
On Error Resume Next
strName = InputBox("Please Enter Search Value." & vbNewLine & "Entry Must Be Exact Cell Value!", "Search Value")
If strName = "" Then Exit Sub
For Each ws In Worksheets
With ws.UsedRange
Set rFound = .Find(What:=strName, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart)
If Not rFound Is Nothing Then
firstaddress = rFound.Address
Application.Goto rFound, True
Exit Sub
End If
End With
Next ws
On Error GoTo 0
MsgBox "Merchant not found. Please make sure you typed it correctly.", vbOKOnly + vbCritical, "Invalid Entry"
You need to modify your search so your code 'remembers' where it left off, like this:
Option Explicit
Dim ws As Worksheet
Dim rFound As Range
Dim strName As String
Static First as Range
'On Error Resume Next
if First is Nothing Then 'we haven't found anything yet
Set First = Worksheets(1).Cells(1,1) 'start searching at the beginning
End If
strName = InputBox("Please Enter Search Value." & vbNewLine & "Entry Must Be Exact Cell Value!", "Search Value")
If strName = "" Then Exit Sub
For Each ws In Worksheets
With ws.UsedRange
Set rFound = .Find(What:=strName, After:=First, LookIn:=xlValues, LookAt:=xlPart)
while Not rFound Is Nothing
if first is nothing then
First = rFound 'store off this address for use in our next search
end if
if first <> rFound Then 'we've found a NEW instance of the search item
firstaddress = rFound.Address
Application.Goto rFound, True
MsgBox "Found one!"
Set rFound = .Find(What:=strName, After:=rFound, LookIn:=xlValues, LookAt:=xlPart)
else 'we're back at the start, so jump out of the loop
set rFound = Nothing
End If
wEnd
End With
Next ws
On Error GoTo 0
MsgBox "Merchant not found. Please make sure you typed it correctly.", vbOKOnly + vbCritical, "Invalid Entry"
A couple of points:
I added Option Explicit which means your code won't run now because you never declared firstaddress. It's vital for your sanity to enable that option from the ribbon: Tools | Options | Editor then check Require Variable Declaration
By declaring First as a Static, it will remain set between calls to your search routine. That way, since we're feeding First into the .Find() function, it will pick up the search where it left off.
If you need to start the search from the beginning again, you could store off the 'last' search term - if the current term is different from the last term, reset set First = Worksheets(1).Cells(1,1)
Additional note - On Error Resume Next is useful in very limited situations. This isn't one of them. It allows you to ignore an error in your code so that you can immediately handle it, which isn't what you want in this situation. The follow up On Error Goto 0, which reenables the default error handling should really never be more than 1 line of code later - not an entire subroutine.
VBA already has a .FindNext() method for this very purpose:
Sub SO()
Dim inputString As String
Dim foundCell As Excel.Range
Dim wSheet As Excel.Worksheet
Dim foundAddress As String
inputString = InputBox("Please enter search term:", "Search")
For Each wSheet In ActiveWorkbook.Worksheets
Set foundCell = wSheet.Cells.Find(inputString, , -4163, 2)
If Not foundCell Is Nothing Then
Application.Goto foundCell, True
foundAddress = foundCell.Address
If MsgBox("Match in " & wSheet.Name & " (" & foundCell.Address & ")" & vbCrLf & "Continue?", 68, "Match Found") = vbYes Then
Do
Set foundCell = wSheet.Cells.FindNext(foundCell)
If Not foundCell Is Nothing And Not foundCell.Address = foundAddress Then
Application.Goto foundCell, True
Else
Exit Do
End If
Loop While MsgBox("Match in " & wSheet.Name & " (" & foundCell.Address & ")" & vbCrLf & "Continue?", 68, "Match Found") = vbYes And _
Not foundCell Is Nothing And Not foundCell.Address = foundAddress
Set foundCell = wSheet.Cells.FindNext(foundCell)
End If
End If
If MsgBox("All matches in this sheet found - move to next sheet?", 68, "Next Sheet?") = vbNo Then Exit Sub
Next wSheet
End Sub

Vlookup in a User form not working, Cant find string

New to VBA, and using it in Excel.
I have a User form, and I am trying to use a lookup to fill TextBox4 from the value that is entered in ComboBox3. I have the following code which compiles, however it is producing the msgbox to say that the string cant be found...
Private Sub ComboBox3_Change()
Dim strFind As String
Dim rFound As Range
ws = "Year-to-Date Summary"
If ComboBox3.ListIndex > -1 Then
strFind = ComboBox3
On Error Resume Next
With ws.Column(2, 3)
Set rFound = .Find(What:="strFind", After:=.Cells(39, 49), _
LookIn:=.Cells(39, 49), LookAt _
:=.Cells(39, 49), SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:= False)
End With
If rFound Is Nothing Then
MsgBox strFind & " cannot be found"
Exit Sub
Else
TextBox4 = rFound(1, 2)
End If
End If
End Sub
I also tried Vlookup, however this sprung error messages...
Private Sub ComboBox3_Change()
TextBox4.Text = WorksheetFunction.VLookup(Val(ComboBox3.Text), _
Sheets("Year-to-Date Summary").Range("C39:C49" & LastRow), 2, False)
End Sub
ws is a variant. You do not assign worksheets like this. You have to use Set
strFind is within quotes so it will be considered as a string
See this example (UNTESTED)
Private Sub ComboBox3_Change()
If ComboBox3.ListIndex = 0 Then Exit Sub
Dim strFind As String
Dim ws As Worksheet
Dim rFound As Range
Set ws = ThisWorkbook.Sheets("Year-to-Date Summary")
strFind = ComboBox3.Value
Set rFound = ws.Columns(3).Find(What:=strFind, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not rFound Is Nothing Then
TextBox4 = rFound.Offset(,1)
Else
MsgBox strFind & " cannot be found"
End If
End Sub
If your range is fixed then change ws.Columns(3) to ws.Range("C39:C49") in the above code.
If you would like to use the worksheet function then you this (TRIED AND TESTED)
Note: I have not used error trapping in the below code. i am sure you can take care of that.
Private Sub ComboBox3_Change()
If ComboBox3.ListIndex = 0 Then Exit Sub
TextBox4.Text = Application.WorksheetFunction.VLookup( _
Val(ComboBox3.Value), _
Sheets("Year-to-Date Summary").Range("C39:D49"), _
2, _
False _
)
End Sub
Note how we used C39:C49 / Columns(3) + Offset in the first example and how we used C49:D49 in the 2nd Example
EDIT: I forgot to comment on On Error Resume Next Never use it until and unless required. It is like telling the code to "shut up!" if it finds an error :)
Your ws is obviously a string, which does not have a .column property.
Replace line ws = "Year-to-Date Summary" by
set ws = worksheets("Year-to-Date Summary") and see if that helps.
Do you make sure that every module has an "Option Explicit" and that your app compiles successfully ? You would have spotted that error I think.
Private Sub ComboBox3_Change()
TextBox4.Text = WorksheetFunction.VLookup(Me.ComboBox3.Text, Sheets("Year-to-Date Summary").Range("$B$39:$C$49"), 2, False)
TextBox3.Text = WorksheetFunction.VLookup(Me.TextBox4.Text, Sheets("Year-to-Date Summary").Range("$C$39:$D$49"), 2, False)
End Sub
This worked for me, to do two textboxes from the combobox
Private Sub ComboBox3_Change()
Dim strFind As String
Dim rFound As Range
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Year-to-Date Summary")
If ComboBox3.ListIndex > -1 Then
strFind = ComboBox3.text
On Error Resume Next
'editted removing the whole vlookup part...
'added for loop to search the text within the range
Set rSearch = ws.Range("B:C")
For Each rFound In rSearch
If rFound.Value = strFind Then
TextBox4.Text = rFound.value
else
MsgBox strFind & " cannot be found"
Exit Sub
End If
Next rFound
End Sub