I'm currently working on a macro enabled excel sheet, with multiple tabs (there are 9 tabs I would like to do this on, but for the purposes of the question I'll include only 2), and for each tab I would like to add a password prompt that matches what I specify in the code.
This is working ok, but my issue is that when two sheets are located next to each other on the actual worksheets tab, it will go through them both rather than hiding the first one until i input the correct password.
For example, on my sheet I have a tab named Cascada, followed by a tab named Cascada2. If I were to put a blank tab inbetween these two, then my code would work correctly. However when they are in sequence, it seems to go through the sequence of password prompts regardless of whether I input the correct string or not.
See code below, any advice would be appreciated.
Thanks.
EDIT UPDATED WITH ANSWER
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Application.EnableEvents = False
Dim cascada As String, cascada2 As String
cascada = "Config_Cascada"
Rhea = "Config_Rhea"
Select Case Sh.Name
Case cascada, cascada2
Dim pwd As String
pwd = "cascada" & IIf(Sh.Name = cascada2, 2, "")
Dim Response As String
Response = InputBox("Enter password to view sheet")
If Response = pwd Then
Sh.Select
Else
Worksheets("Doors").Activate
End If
End Select
Select Case Sh.Name
Case Rhea
Dim pwdRhea As String
pwdRhea = "rhea"
Dim ResponseRhea As String
ResponseRhea = InputBox("Enter password to view sheet")
If Response = pwdRhea Then
Sh.Select
Else
Worksheets("Doors").Activate
End If
End Select
Application.EnableEvents = True
End Sub
Give this a shot. Cleaner and works as far as I tested:
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Application.EnableEvents = False
Dim cascada As String, cascada2 As String
cascada = "config_Cascada"
cascada2 = "config_Cascada2"
Select Case Sh.Name
Case cascada, cascada2
Dim pwd As String
pwd = "cascada" & IIf(Sh.Name = cascada2, 2, "")
Dim Response as String
Response = InputBox("Enter password to view sheet")
If Response = pwd Then
Sh.Select
End If
End Select
Application.EnableEvents = True
End Sub
Related
How would you save or update a TextBox with its own value the user has inputted?
Example, I have a Userform with a TextBox for "password". Every user who opens the file will enter his own password in that TextBox, then save the file and reopen at any given time.
Note, the value should be saved permanently in that file (not only session based), so even after completely closing and reopening the file, the users password should be there in the Textbox until its changed again.
Passing the value to cell isn't a good idea, since its a password and shouldn't be visible.
I used so far below code, to no avail.
In the UF code for "Save" button:
Private Sub CommandButton1_Click()
SavePWStrings
Me.Hide
End Sub
In the standard module:
Public Sub SavePWStrings()
Dim pw As String
pw = UserForm1.TextBox1.Value
UserForm1.TextBox1 = pw
End Sub
Goal is to update the value of the TextBox programmatically as below.
Thanks
As I mentioned in the comments, here is an unusual way to achieve what you want. You can store the username/password in the module.
Module Setup
Insert a Module. Let's call it MyModule. Paste the below code there
Option Explicit
Private Sub UserDatabase()
'USER|sid_sid_sid|PASSWORD
'
'
'
End Sub
NOTE: Not that it matters but to make it look concise and manageable, ensure that there are no blank lines after End Sub.
|sid_sid_sid| is a separator that I am using to seperate the user from the password. Feel free to change that. Ensure that it is a unique text.
Userform Setup
And let's say your userform looks like this
Paste this code in the userform code area. The name of the textbox is txtPassword
Option Explicit
Dim proj As VBIDE.VBProject
Dim comp As VBIDE.VBComponent
Dim codeMod As VBIDE.CodeModule
Dim lineCount As Long
Dim i As Long
Dim doNotReEnter As Boolean
Dim oldPassword As String
Dim newPassword As String
'~~> Separator for Username / Password
Private Const MySep As String = "|sid_sid_sid|"
'~~> Userform Initialize Event
Private Sub UserForm_Initialize()
Dim currentUser As String
'~~> Get the username
currentUser = Environ("UserName")
lblUser.Caption = "USER :" & currentUser
'~~> Check if user exists
If DoesUserExist(currentUser) Then
'~~> If it does then get the password
txtPassword.Text = GetUserPassword(currentUser)
oldPassword = txtPassword.Text '<~~ Store current password in a variable
End If
End Sub
'~~> Login button
Private Sub CommandButton1_Click()
'~~> Get the password from the textbox
newPassword = txtPassword.Text
'~~> Check if they match. If they do then do not store else store
If newPassword <> oldPassword And Len(Trim(newPassword)) <> 0 Then
Dim modLine As String
modLine = " '" & Environ("UserName") & MySep & txtPassword.Text
Set proj = ThisWorkbook.VBProject
Set comp = proj.VBComponents("MyModule")
Set codeMod = comp.CodeModule
codeMod.InsertLines codeMod.CountOfLines - 1, modLine
End If
End Sub
'~~> Function to check if the user is there in the module
Private Function DoesUserExist(xlUser As String) As Boolean
Set proj = ThisWorkbook.VBProject
Set comp = proj.VBComponents("MyModule")
Set codeMod = comp.CodeModule
lineCount = codeMod.CountOfLines
For i = 1 To lineCount
If codeMod.Find(xlUser, i, 1, -1, -1) Then
DoesUserExist = True
Exit For
End If
Next i
End Function
'~~> Function to get the password for a user
Private Function GetUserPassword(xlUser As String) As String
Set proj = ThisWorkbook.VBProject
Set comp = proj.VBComponents("MyModule")
Set codeMod = comp.CodeModule
lineCount = codeMod.CountOfLines
For i = 1 To lineCount
If codeMod.Find(xlUser, i, 1, -1, -1) Then
GetUserPassword = Split(codeMod.Lines(i, 1), MySep)(1)
Exit For
End If
Next i
End Function
Basic Setup
In VBE, click on TOOLS|REFERENCES and check the Microsoft Visual Basic for Applications Extensibility 5.3 as shown below
Enable trust access to the VBA project object model. Click FILE | OPTIONS. In the navigation pane, select TRUST CENTER. Click TRUST CENTER SETTINGS. In the navigation pane, select MACRO SETTINGS. Ensure that Trust access to the VBA project object model is checked. Click OK.
Now if you notice that this will work when the VBA Project is Unprotected. So how do we make it work when the VBA project is Locked. For that, use the code from HERE. Port all that code inside the userform and do not keep that code in the module.
For additional security, you can encrypt the data before storing it in a module. Lot of examples in the web on how to encrypt/decrypt a string in VBA.
For demonstration purpose, I have VBA unlocked.
Sample File: The file can be downloaded from HERE
I am trying to identify the username from a range and then return the FilePerUser name.
When I run the code, the open file name only identifies the FileDir variable (\network\test folder\destination) not including the FilePerUser from the select statement.
Sub datapull_manual()
Dim FilePerUser As String
Dim User As Variant
User = Worksheets("prp").Range("v2")
Dim FileDir As String
FileDir = "\\network\test folder\destination\"
'user names to automatically open file as per every user
Select Case FilePerUser
Case User = "Mo"
FilePerUser = "k111"
Case User = "To"
FilePerUser = "k222"
Case User = "Vo"
FilePerUser = "k333"
End Select
Workbooks.Open Filename:=(FileDir & FilePerUser)
Columns("A:S").Copy
Windows("Test.xlsb").Activate
Sheets("test123").Select
Cells.Select
Range("A2").Activate
ActiveSheet.Paste
end sub
Change your Select-statement:
Select Case user
Case "Mo"
filePerUser = "k111"
Case "To"
filePerUser = "k222"
Case "Vo"
filePerUser = "k333"
Case else
MsgBox "User not found"
exit sub
End Select
As #FunThomas pointed out - you're using the wrong syntax in the Select Case statement.
You're also not adding the file extension to the file name. Currently you're looking for a file called "k111" not "k111.xlsx".
This code should work:
Sub datapull_manual()
Dim FilePerUser As String
Dim User As Variant
User = Worksheets("prp").Range("v2")
Dim FileDir As String
FileDir = "\\network\test folder\destination\"
'user names to automatically open file as per every user
'Change Case to look at 'User' variable.
'Case "Mo", not 'Case User = "Mo"'
Select Case User
Case "Mo"
FilePerUser = "K111.xlsx"
Case "To"
FilePerUser = "k222.xlsx"
Case "Vo"
FilePerUser = "k333.xlsx"
End Select
Workbooks.Open Filename:=(FileDir & FilePerUser)
Columns("A:S").Copy
Windows("Test.xlsb").Activate
Sheets("test123").Select
Cells.Select
Range("A2").Activate
ActiveSheet.Paste
End Sub
The bottom part of your code could be improved by referencing the workbooks with variables:
Sub datapull_manual()
Dim FilePerUser As String
Dim User As Variant
Dim WB As Workbook
Dim WB1 As Workbook
User = Worksheets("prp").Range("v2")
Dim FileDir As String
FileDir = "\\network\test folder\destination\"
'user names to automatically open file as per every user
'Change Case to look at 'User' variable.
'Case "Mo", not 'Case User = "Mo"'
Select Case User
Case "Mo"
FilePerUser = "k111.xlsx"
Case "To"
FilePerUser = "k222.xlsx"
Case "Vo"
FilePerUser = "k333.xslx"
End Select
'Open & set reference to the workbook.
Set WB = Workbooks.Open(Filename:=FileDir & FilePerUser)
Set WB1 = Workbooks("Test.xlsb") 'Set reference to Test workbook.
'Set WB1 = ThisWorkbook 'If Test.xlsb is the workbook containing this code.
'Use references to copy data - no need to activate or select anything.
WB.Worksheets("Sheet1").Columns("A:S").Copy _
Destination:=WB1.Worksheets("Test123").Range("A2")
End Sub
Looking for a little help, I have an excel document that should only grant certain users access, all employees have a user name and when they input any information that shows up with their entry. I'm hoping to secure the file so that only certain employees can have access. So far I have
Private Sub Workbook_Open()
Dim Users As Variant
Dim UName As String
Dim UFind As Variant
Users = Array("JBLOGS", "DOEJOHN", "ASmith", "JanDoe")
UName = Environ("UserName")
On Error Resume Next
UFind = WorksheetFunction.Match(UName, Users, 0)
If Err <> 0 Then
MsgBox "You are not authorised to use this Workbook"
ThisWorkbook.Close SaveChanges:=False
End If
End Sub
This is fine, but I had wanted it to be on a sheet of its own ie column titled Users then a list of users that can be added to easily.
I also was wondering if certain users could be restricted to certain sheets, for example, John Doe is in Africa, Jane is in America, can I restrict them to only see sheets titled 'Africa' and 'America'
Had a look and couldn't see anything, so not sure if it easily done...
I'd suggest creating a hidden worksheet to hold your list of usernames, you can even protect the hidden sheet with a password if desired. Additionally, you could expand your username list to a table that lists the worksheets each user is allowed to view. Any sheets disallowed by the table could also be hidden from that user (and, of course, unhidden for a different user with granted access). As a side note, you may find it useful to make a case-insensitive comparison of usernames from the table to the environment variable - this has tripped me up sometimes.
EDIT1: Here's an example to get you started:
Create a worksheet named "AuthUsers" and then create a table named "UserTable". Define two columns in the table, the first called "Users" and the second called "Sheets".
EDIT2: Added the ViewAuthorizedSheets method to hide/view appropriate worksheets and updated the test sub. This also works just fine when called from Worksheet_Open.
Option Explicit
Sub test()
Debug.Print "user is authorized = " & IsUserAuthorized(Environ("UserName"))
ViewAuthorizedSheets Environ("UserName")
If IsUserAuthorized(Environ("UserName")) Then
Debug.Print "authorized sheets = " & GetAuthorizedSheets(Environ("UserName"))
Else
MsgBox "User is not authorized to view any sheets.", vbCritical + vbOKOnly
End If
End Sub
Public Sub ViewAuthorizedSheets(uname As String)
Dim authSheets As String
Dim sh As Worksheet
uname = Environ("UserName")
authSheets = GetAuthorizedSheets(uname)
For Each sh In ThisWorkbook.Sheets
If sh.Name <> "AuthUsers" Then
If InStr(1, authSheets, sh.Name, vbTextCompare) > 0 Then
sh.Visible = xlSheetVisible
Else
sh.Visible = xlSheetHidden
End If
End If
Next sh
End Sub
Function IsUserAuthorized(uname As String) As Boolean
Dim ws As Worksheet
Dim userTbl As ListObject
Dim userList As Range
Dim allowedUser As Variant
Dim allowed As Boolean
Set ws = ThisWorkbook.Sheets("AuthUsers")
Set userTbl = ws.ListObjects("UserTable")
Set userList = userTbl.ListColumns("Users").DataBodyRange
allowed = False
For Each allowedUser In userList
If LCase(allowedUser) = LCase(uname) Then
allowed = True
Exit For
End If
Next allowedUser
Set userList = Nothing
Set userTbl = Nothing
Set ws = Nothing
IsUserAuthorized = allowed
End Function
Function GetAuthorizedSheets(uname As String) As String
Dim ws As Worksheet
Dim userTbl As ListObject
Dim userList As Range
Dim allowedUser As Variant
Dim allowed As String
Set ws = ThisWorkbook.Sheets("AuthUsers")
Set userTbl = ws.ListObjects("UserTable")
Set userList = userTbl.DataBodyRange
allowed = False
For Each allowedUser In userList.Columns(1).Cells
If LCase(allowedUser) = LCase(uname) Then
allowed = allowedUser.Offset(0, 1).value
Exit For
End If
Next allowedUser
Set userList = Nothing
Set userTbl = Nothing
Set ws = Nothing
GetAuthorizedSheets = allowed
End Function
In your ThisWorkbook module, the call is accessed simply by
Option Explicit
Private Sub Workbook_Open()
ViewAuthorizedSheets Environ("UserName")
End Sub
Private Sub Workbook_Open()
Dim EmpArray(3) As String
Dim Count As Integer
EmpArray(0) = "dzcoats"
EmpArray(1) = "cspatric"
EmpArray(2) = "eabernal"
EmpArray(3) = "lcdotson"
Count = 0
For i = LBound(EmpArray) To UBound(EmpArray)
If Application.UserName = EmpArray(i) Then Count = Count = 1
Next i
If Count = 0 Then
MsgBox ("You dont have access to this file")
ThisWorkbook.Close SaveChanges:=False
End If
End Sub
This should work. My Count logic is sloppy though but it does the trick
new and would like to ask if someone could possibly check my code to see where i'm making a mistake.
first, i've created a form with two textboxes and two buttons that will go and get two different directories and the associated files. this is done through a call to a function that loads the dir to the textboxes.
a button to call a function to navigate dir and get the file
Private Sub CommandButton3_Click()
'call selectFile function to select file
selectFile
End Sub
function to get workbooks into textboxes 1 and 2:
Public Function selectFile()
Dim fileNamePath1 As String
Dim fileNamePath2 As String
Dim workbookFilePath1 As String
Dim workbookFilePath2 As String
On Error GoTo exit_
If workbookFilePath1 = Empty And workbookFilePath2 = Empty Then
fileNamePath1 = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Open Workbook 1", MultiSelect:=False)
workbookFilePath1 = Dir(fileNamePath1)
'TextBox1.Text = workbookFilePath1
TextBox1.Value = fileNamePath1
fileNamePath2 = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Open Workbook 2", MultiSelect:=False)
workbookFilePath2 = Dir(fileNamePath2)
TextBox2.Value = fileNamePath2
If fileNamePath1 = False Or fileNamePath2 = False Then
MsgBox ("File selection was canceled.")
Exit Function
End If
End If
exit_:
End Function
up to here, the code is ok... can do better, but
here's where problems occur... i'd like to pass the directories as objects into the module to diff
button that executes module to diff:
Private Sub CommandButton1_Click()
getTheWorkbooksToCompare(fileNamePath1, fileNamePath2)
End Sub
i know that i've changed myPath1 and myPath2 to Workbooks, where I've had them as strings before
diffing module
Public Sub gettheWorkbooksToCompare(myPath1 As Workbook, myPath2 As Workbook)
Dim myExcelObj
Dim WorkbookObj1
Dim WorkbookObj2
Dim WorksheetObj1
Dim WorksheetObj2
Dim file1 As String
Dim file2 As String
Dim myWorksheetCounter As Integer
Dim i As Worksheet
Set myExcelObj = CreateObject("Excel.Application")
myExcelObj.Visible = True
Set file1 = Dir(myPath1)
Set file2 = Dir(myPath2)
Set WorkbookObj1 = myExcelObj.Workbooks.Open(file1)
Set WorkbookObj2 = myExcelObj.Workbooks.Open(file2)
Set NewWorkbook = myExcelObj.Workbooks.Add
While WorkbookObj1 <> Null And WorkbookObj2 <> Null
'While WorkbookObj1.ActiveWorkbook.Worksheets.count = WorkbookOjb2.ActiveWorkbook.Worksheets.count
myWorksheetCounter = ActiveWorkbook.Worksheets.count
myWorksheetCount = ActiveWorkbook.Worksheets.count
If WorksheetObj1.Worksheets.myWorksheetCounter = WorkbookObj2.Worksheets.myWorksheetCounter Then
Set WorksheetObj1 = WorkbookObj1.Worksheets(myWorksheetCounter)
Set WorksheetObj2 = WorkbookObj2.Worksheets(myWorksheetCounter)
Set myNewWorksheetObj = NewWorkbook.Worksheets(myWorksheetCounter)
For myWorksheetCounter = i To WorksheetObj1
For myWorksheetCount = j To WorksheetOjb2
'If cell.Value myWorksheetObj2.Range(cell.Address).Value Then
If cell.Value = myWorksheetObj2.Range(cell.address).Value Then
myNewWorksheetObj.Range(cell.address).Value = cell.address.Value
myNewWorksheetObj.Range(cell.address).Interior.ColorIndex = 3
Else
cell.Interior.ColorIndex = 0
End If
Next
'if doesn't work... use SaveChanges = True
myNewWorksheetObj.Workbooks.Save() = True
Next
Else
MsgBox ("The worksheets are not the same worksheets." & vbNewLine & "Please try again.")
End If
Wend
Set myExcelObj = Nothing
End Sub
So my question is... can someone please assist in seeing where i'm going wrong? essentially, i'm having some issues in trying to get this working.
much appreciated
i've gone through and cleaned up some areas a little bit... but now have a: "run time error '438': object doesn't support this propety or method" at the while loop code that i've updated the post with
I see a typo on CommandButton1_Click
Private Sub CommandButton1_Click()
getTheWorkbooksToCompare(fileNamePath1, fileNamePath2)
End Sub
Public Sub gettheWorkbooksToCompare(myPath1 As Workbook, myPath2 As Workbook)
There might be something more, but your not capitalizing the "T" in getThe, but you call it that way.
I am newbie in Excel. I need to something like below.
When user click on a cell or enter to cell:
It should automatically open/close file window.
When user select a file, it should pick up path/filename and put into the cell, like c:\folder1\file1.ext
If user select more than one file, it should pick up all path/filenames into cell,with | as delimiter. like c:\folder1\file1.ext|d:\folder2\file2.ext
If user click on a cell or enter to cell for a second time, it should keeps existing path/filenames and let to add other path/filnames to them like in number 3
This is similar to Sid's, just lets you double click any single cell to open the file dialog.
In a Module
Public Function getList(Optional ByVal Target As Range = Nothing) As String
Dim Dialog As FileDialog
Dim File As Integer
Dim Index As Integer
Dim List() As String
Dim Item As Integer
Dim Skip As Boolean
Set Dialog = Application.FileDialog(msoFileDialogFilePicker)
File = Dialog.Show
If File = -1 Then
' Get a list of any pre-existing files and clear the cell
If Not Target Is Nothing Then
List = Split(Target.Value, "|")
Target.Value = ""
End If
' Loop through all selected files, checking them against any pre-existing ones to prevent duplicates
For Index = 1 To Dialog.SelectedItems.Count
Skip = False
For Item = LBound(List) To UBound(List)
If List(Item) = Dialog.SelectedItems(Index) Then
Skip = True
Exit For
End If
Next Item
If Skip = False Then
If Result = "" Then
Result = Dialog.SelectedItems(Index)
Else
Result = Result & "|" & Dialog.SelectedItems(Index)
End If
End If
Next Index
' Loop through the pre-existing files and add them to the result
For Item = UBound(List) To LBound(List) Step -1
If Not List(Item) = "" Then
If Result = "" Then
Result = List(Item)
Else
Result = List(Item) & "|" & Result
End If
End If
Next Item
Set Dialog = Nothing
' Set the target output if specified
If Not Target Is Nothing Then
Target.Value = Result
End If
' Return the string result
getList = Result
End If
End Function
In Your Worksheet's Code
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Rows.Count = 1 And Target.Columns.Count = 1 Then getList Target
End Sub
Update
I've changed the getList function (it wasn't broken, just made it do more)
It will allow you to double click any cell, which will open a file dialog.
You can select 1 (or more) files
The file names will be joined with the "|" character and put in the target cell
If any pre-existing files are in the cell, the new ones will be appended to them
It does not however support pressing enter to open the file dialog, you must double-click the cell.
Update
To help VMO (commenter)
The code in the worksheet module:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Rows.Count = 1 And Target.Columns.Count = 1 Then
If Target.Address = "$A$1" Then ' See Notes Below
Target.Value = getList(Target)
End If
End If
End Sub
To restrict what cell(s) are double-click'able you will need to use something like that. You can change $A$1 to whatever you want or find a way to determine the target range's name (not too difficult)
If your worksheet is not locked the cell that is clicked will keep focus, and be in edit-mode which is a little annoying. Locking the cell, in previous versions of excel fixed this (i think it doesn't work in v.2010+ though)
The code in the module (getList) can remain almost exactly the same (although you might want to remove all the code that deals with multiple files, not required though). All you need to do is add one line of code.
.......
Dim Skip As Boolean
Set Dialog = Application.FileDialog(msoFileDialogFilePicker)
Dialog.AllowMultiSelect = False ' This will restrict the dialogue to a single result
File = Dialog.Show
If File = -1 Then
......
Hope this helps and I've understood what you were asking!
This should do the trick. The first subroutine is the event that is triggered on the user clicking on a cell. Change the row and column numbers in the first if statement to change the target cell. You can put all of this code in the code module for the worksheet you want it to work on.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim filenames() As String
Dim filename As Variant
Dim filelist As String
' Make sure the user clicked our target cell
If Target.Row = 2 And Target.Column = 2 Then
' Get a list of filenames
filenames = GetFileNames
' Make sure we got some filenames
If UBound(filenames) > 0 Then
' Go through the filenames, adding each to the output string
For Each filename In filenames
filelist = filelist & CStr(filename) & "|"
Next filename
' Remove the final delimiter
filelist = Left(filelist, Len(filelist) - 2)
' Apply the output string to the target cell (adding another
' delimiter if there is already text in there)
If Not Target.Value = "" Then
Target.Value = Target.Value & "|"
End If
Target.Value = Target.Value & filelist
End If
End If
End Sub
The following function is that which is called to open the file dialogue and retrieve the filenames.
Private Function GetFileNames() As String()
Dim dlg As FileDialog
Dim filenames() As String
Dim i As Integer
' Open a file dialogue
Set dlg = Application.FileDialog(msoFileDialogFilePicker)
With dlg
.ButtonName = "Select" ' Text of select/open button
.AllowMultiSelect = True ' Allows more than one file to be selected
.Filters.Add "All Files", "*.*", 1 ' File filter
.Title = "Select file(s)" ' Title of dialogue
.InitialView = msoFileDialogViewDetails
.Show
' Redimension the array with the required number of filenames
ReDim filenames(.SelectedItems.Count)
' Add each retrieved filename to the array
For i = 1 To .SelectedItems.Count
filenames(i - 1) = .SelectedItems(i)
Next i
End With
' Clean up and return the array
Set dlg = Nothing
GetFileNames = filenames
End Function