When locking a sheet, the VB Code stops working - vb.net

Here is my code; when I lock the sheet the code stops working and will not pop up on the double click.
On another note is there a way to activate the code without requiring it to double click?
Private Sub Worksheet_Activate()
End Sub
'==========================
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet
Set cboTemp = ws.OLEObjects("NameBox")
On Error Resume Next
With cboTemp
'clear and hide the combo box
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
On Error GoTo errHandler
If Target.Validation.Type = 3 Then
'if the cell contains a data validation list
Cancel = True
Application.EnableEvents = False
'get the data validation formula
str = Target.Validation.Formula1
str = Right(str, Len(str) - 1)
With cboTemp
'show the combobox with the list
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = str
.LinkedCell = Target.Address
End With
cboTemp.Activate
'open the drop down list automatically
Me.NameBox.DropDown
End If
errHandler:
Application.EnableEvents = True
Exit Sub
End Sub
'=========================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet
Application.EnableEvents = False
Application.ScreenUpdating = True
If Application.CutCopyMode Then
'allow copying and pasting on the worksheet
GoTo errHandler
End If
Set cboTemp = ws.OLEObjects("NameBox")
On Error Resume Next
With cboTemp
.Top = 10
.Left = 10
.Width = 0
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With
errHandler:
Application.EnableEvents = True
Exit Sub
End Sub
'====================================
'Optional code to move to next cell if Tab or Enter are pressed
'from code by Ted Lanham
'***NOTE: if KeyDown causes problems, change to KeyUp
Private Sub NameBox_KeyDown(ByVal _
KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
Select Case KeyCode
Case 9 'Tab
ActiveCell.Offset(0, 1).Activate
Case 13 'Enter
ActiveCell.Offset(1, 0).Activate
Case Else
'do nothing
End Select
End Sub
'====================================

Related

Trying to use vba lookup to get values from other workbooks

Another go still not working
Private Sub Worksheet_Change(ByVal Target As Range)
If Me.ListBox4 = "Fill Details" Then
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Dim src As Workbook
Dim JCM As Worksheet
Set src = Workbooks.Open("\\TGS-SRV01\Share\ShopFloor\PRODUCTION\JOB BOOK\JOB RECORD SHEET.xlsm", True, True)
Set JCM = Worksheets("Job Card Master")
Dim iTotalRows As Integer
iTotalRows = src.Worksheets("sheet1").Range("A1:A" & Cells(rows.Count, "A").End(xlUp).row).rows.Count
Dim iCnt As Integer
For iCnt = 2 To iTotalRows
Sheet1.Cells(40 & iCnt) = Application.WorksheetFunction.VLookup(JCM.Cells("G2"), _
Sheets(JCM).Range("A4"), iCnt, 0)
Next iCnt
src.Close False
Set src = Nothing
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Successfully entered Job Book data to Job Card Master Headers"
End If
End Sub

How do I apply a macro to multiple excel files when the macro contains many subs?

I have used a macro to track changes in a workbook, but I would now like to run this macro in over a 100 excel files within a particular folder using a Do While Loop.
I am very new to VBA and will appreciate all the help I can get.
I have come across some code that should enable me to loop through excel files in a folder and run the macro in each one.
However it requires me to get rid of the 'sub' and 'end sub' from the macro when I copy and paste it into the do while loop, but I have 3 of them within the macro; some variables will be undefined if I delete all 3.
Therefore I tried 'Call Tracker' within the loop ('Tracker' being the macro name) and hoped it would run in each excel file.
Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*,xls*")
Do While xFileName <> ""
With Workbooks.Open(xFdItem & xFileName)
'Your code here
Call Tracker
End With
xFileName = Dir
Loop
End If
End Sub
Below is the code inside 'Tracker'
Option Explicit
Dim sOldAddress As String
Dim vOldValue As Variant
Public Sub Workbook_TrackChange(Cancel As Boolean)
Dim Sh As Worksheet
For Each Sh In ActiveWorkbook.Worksheets
Sh.PageSetup.LeftFooter = "&06" & ActiveWorkbook.FullName & vbLf & "&A"
Next Sh
End Sub
Public Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim wSheet As Worksheet
Dim wActSheet As Worksheet
Dim iCol As Integer
Set wActSheet = ActiveSheet
'Precursor Exits
'Other conditions that you do not want to track could be added here
If vOldValue = "" Then Exit Sub 'If you comment out this line *every* entry will be recorded
'Continue
On Error Resume Next ' This Error-Resume-Next is only to allow the creation of the tracker sheet.
Set wSheet = Sheets("Tracker")
'**** Add the tracker Sheet if it does not exist ****
If wSheet Is Nothing Then
Set wActSheet = ActiveSheet
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Tracker"
End If
On Error GoTo 0
'**** End of specific error resume next
On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With Sheets("Tracker")
'******** This bit of code moves the tracker over a column when the first columns are full**'
If .Cells(1, 1) = "" Then '
iCol = 1 '
Else '
iCol = .Cells(1, 256).End(xlToLeft).Column - 7 '
If Not .Cells(65536, iCol) = "" Then '
iCol = .Cells(1, 256).End(xlToLeft).Column + 1 '
End If '
End If '
'********* END *****************************************************************************'
.Unprotect Password:="Secret"
'******** Sets the Column Headers **********************************************************
If LenB(.Cells(1, iCol).Value) = 0 Then
.Range(.Cells(1, iCol), .Cells(1, iCol + 7)) = Array("Cell Changed", "SAP ID", "Field Name", "Old Field Value", _
"New Field Value", "Time of Change", "Date Stamp", "User")
.Cells.Columns.AutoFit
End If
With .Cells(.Rows.Count, iCol).End(xlUp).Offset(1)
If Target.Count = 1 Then
.Offset(0, 1) = Cells(Target.Row, 2) 'SAPID
End If
'.Offset(0, 1) = Cells(Target.Row, 2) 'SAPID
If Target.Count = 1 Then
.Offset(0, 2) = Cells(Target.Column) 'Field name
End If
'.Offset(0, 2) = Cells(Target.Column) 'Field name
.Value = sOldAddress
.Offset(0, 3).Value = vOldValue
If Target.Count = 1 Then
.Offset(0, 4).Value = Target.Value
End If
.Offset(0, 5) = Time
.Offset(0, 6) = Date
.Offset(0, 7) = Application.UserName
.Offset(0, 7).Borders(xlEdgeRight).LineStyle = xlContinuous
End With
.Protect Password:="Secret" 'comment to protect the "tracker tab"
End With
ErrorExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
wActSheet.Activate
Exit Sub
ErrorHandler:
'any error handling you want
'Debug.Print "We have an error"
Resume ErrorExit
End Sub
Public Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
With Target
sOldAddress = .Address(external:=True)
If .Count > 1 Then
vOldValue = "Multiple Cell Select"
Else
vOldValue = .Value
End If
End With
End Sub
'Call Tracker' in the loop does not produce an error. In fact the code seems to execute and loops through all the files but it does not run the macro in each one it opens.

dropdown list with autocomplete/ suggestion in excel vba

In a merged cell (named as SelName) I have a dropdown list with more then 100 items. Searching through the list is not efficient, as this list is constantly growing. Therefore, I would like to have a dropdown list with autocomplete/ suggestion function. One of the codes that I have is the following which I have found on extendoffice.com:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Update by Extendoffice: 2017/8/15
Dim xCombox As OLEObject
Dim xStr As String
Dim xWs As Worksheet
Dim Cancel As Boolean
Set xWs = Application.ActiveSheet
'On Error Resume Next
Set xCombox = xWs.OLEObjects("TempCombo")
With xCombox
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
If Target.Validation.Type = 3 Then
Target.Validation.InCellDropdown = False
Cancel = True
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xCombox
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = xStr
.LinkedCell = Target.Address
End With
xCombox.Activate
Me.TempCombo.DropDown
End If
End Sub
Private Sub TempCombo_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 9
Application.ActiveCell.Offset(0, 1).Activate
Case 13
Application.ActiveCell.Offset(1, 0).Activate
End Select
End Sub
First, I tried to test it in an empty sheet (with just the dropdown list) and it worked well. But as soon as I try to insert this code into the other worksheet, it doesn't. Does anyone has an idea what the problem could be?
FYI: I have several drop down lists in this worksheet and all of them are in merged cells. Additionally, I have some other Private subs...
Why do you have to do that instead of just creating a ComboBox control and setting ListFillRange and LinkedCell without any code?
The error happens because the Range you are editing (Target) does not have any Validation. You should add the check for validation:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim vType As XlDVType
On Error GoTo EndLine
vType = Target.Validation.Type
Dim xCombox As OLEObject
Dim xStr As String
Dim xWs As Worksheet
Dim Cancel As Boolean
Set xWs = Application.ActiveSheet
'On Error Resume Next
Set xCombox = xWs.OLEObjects("TempCombo")
With xCombox
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
If vType = 3 Then
Target.Validation.InCellDropdown = False
Cancel = True
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xCombox
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = xStr
.LinkedCell = Target.Address
End With
xCombox.Activate
Me.TempCombo.DropDown
End If
EndLine:
End Sub
EDIT
If i understand the problem correctly, you want a ComboBox that auto-fills from a column and auto-updates if you type more entries in the column. There is no need for such complicated code. You can simply add a ComboBox (say ComboBox1), set its ListFillRange (e.g. to A1:A20) and do this:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With ComboBox1
Dim OrigRange As Range: OrigRange = .ListFillRange
If Not Application.Intersect(OrigRange, Target) Is Nothing Then
.ListFillRange = .OrigRange.Resize(OrigRange.Cells(1).End(xlDown).Row - OrigRange.Row + 1)
End If
End With
End Sub
Autocomplete Dropdowns are now native with excel O365
https://www.excel-university.com/autocomplete-for-data-validation-dropdown-lists/

Excel renaming Activex Controls on other computers

I have a worksheet with Activex Controls(Combobox, Command Button, Option Button, CheckBox).
On my computer I have renamed all the controls (Ex. CButtonPMR, OButton_Comp, etc)
But when I open the file on other computer all the controls are renamed to default the default names (CheckBox1,Checkbox2, CommandButton1, etc)
For that reason the code doesn't works on other computers.
I am getting errors every time because the code can't compile.
Is there a way to fix this?
I basically have 2 forms into one and there is 2 option button to chose wich one you want.
When the user select a Button the other form is Hidden
Private Sub OpButtonComp_Click()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Dim protect As Boolean
protect = False
If ActiveSheet.ProtectContents Then
protect = True
ActiveSheet.Unprotect Password:="password"
End If
Application.ScreenUpdating = False
ActiveSheet.Rows("13:61").Hidden = True
ActiveSheet.Rows("62:86").Hidden = False
ActiveSheet.Rows("6").Hidden = True
Dim rng As Range
Set rng = ActiveSheet.Range("A62:P62")
With ActiveSheet.OLEObjects("CButtonPMB")
.Top = rng.Top
.Left = rng.Left
.Width = rng.Width
.Height = rng.RowHeight
End With
ActiveSheet.OLEObjects("CButtonPMB").Visible = True
Set rng = ActiveSheet.Range("A72:P72")
With ActiveSheet.OLEObjects("CButtonMQSB")
.Top = rng.Top
.Left = rng.Left
.Width = rng.Width
.Height = rng.RowHeight
End With
ActiveSheet.OLEObjects("CButtonMQSB").Visible = True
Set rng = ActiveSheet.Range("A79:P79")
With ActiveSheet.OLEObjects("CButtonMQS2B")
.Top = rng.Top
.Left = rng.Left
.Width = rng.Width
.Height = rng.RowHeight
End With
ActiveSheet.OLEObjects("CButtonMQS2B").Visible = True
Set rng = ActiveSheet.Range("A85:P85")
With ActiveSheet.OLEObjects("CButtonPM2B")
.Top = rng.Top
.Left = rng.Left
.Width = rng.Width
.Height = rng.RowHeight
End With
ActiveSheet.OLEObjects("CButtonPM2B").Visible = True
Application.ScreenUpdating = True
If Not (ActiveSheet.ProtectContents) And protect = True Then
ActiveSheet.protect Password:="password"
End If
End Sub
Private Sub OpButtonCon_Click()
Dim protect As Boolean
protect = False
If ActiveSheet.ProtectContents Then
protect = True
ActiveSheet.Unprotect Password:="password"
End If
Application.ScreenUpdating = False
ActiveSheet.Rows("13:61").Hidden = False
ActiveSheet.Rows("62:86").Hidden = True
ActiveSheet.Rows("6").Hidden = False
ActiveSheet.CButtonPMB.Visible = False
ActiveSheet.CButtonMQSB.Visible = False
ActiveSheet.CButtonMQS2B.Visible = False
ActiveSheet.CButtonPM2B.Visible = False
Application.ScreenUpdating = True
If Not (ActiveSheet.ProtectContents) And protect = True Then
ActiveSheet.protect Password:="password"
End If
End Sub
This is to pop up a DatePicker Form when those cells are selected.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Only look at that range
If Intersect(Target, Range("N12:P12")) Is Nothing _
And Intersect(Target, Range("N15:P15")) Is Nothing _
And Intersect(Target, Range("N29:P29")) Is Nothing _
And Intersect(Target, Range("N37:P37")) Is Nothing _
And Intersect(Target, Range("N44:P44")) Is Nothing _
And Intersect(Target, Range("N50:P50")) Is Nothing _
And Intersect(Target, Range("N51:P51")) Is Nothing _
And Intersect(Target, Range("N59:P59")) Is Nothing _
And Intersect(Target, Range("N70:P70")) Is Nothing _
And Intersect(Target, Range("N78:P78")) Is Nothing _
And Intersect(Target, Range("N83:P83")) Is Nothing Then
Exit Sub
Else
'Show Datepicker
CalendarFrm.Show
End If
End Sub
Thank you
Since my answer was deleted I'll post the solution here.
If anyone is wondering, I managed to fix it by following this http://www.excelclout.com/microsoft-update-breaks-excel-activex-controls-fix/
Copy and paste the following VBA code into any module in the spreadsheet.
Public Sub RenameMSFormsFiles()
Const tempFileName As String = "MSForms - Copy.exd"
Const msFormsFileName As String = "MSForms.exd"
On Error Resume Next
'Try to rename the C:\Users\[user.name]\AppData\Local\Temp\Excel8.0\MSForms.exd file
RenameFile Environ("TEMP") & "\Excel8.0\" & msFormsFileName, Environ("TEMP") & "\Excel8.0\" & tempFileName
'Try to rename the C:\Users\[user.name]\AppData\Local\Temp\VBE\MSForms.exd file
RenameFile Environ("TEMP") & "\VBE\" & msFormsFileName, Environ("TEMP") & "\VBE\" & tempFileName
End Sub
Private Sub RenameFile(fromFilePath As String, toFilePath As String)
If CheckFileExist(fromFilePath) Then
DeleteFile toFilePath
Name fromFilePath As toFilePath
End If
End Sub
Private Function CheckFileExist(path As String) As Boolean
CheckFileExist = (Dir(path) <> "")
End Function
Private Sub DeleteFile(path As String)
If CheckFileExist(path) Then
SetAttr path, vbNormal
Kill path
End If
End Sub
Call the RenameMSFormsFiles subroutine at the very beginning of the workbook_Open event.
Private Sub Workbook_Open()
RenameMSFormsFiles
End Sub

Data validation and combo box in a cell - Workbook_SheetChange event not working

I have adapted the following code from Contextures website which adds combo box functionality into cells containing data validation. Though comboboxes display well where they should, I am still facing two issues.
First, I would need that after chosing value in "D4" cell, which combines data validation and combo box, the same value was displayed on other sheets in "D4" cell in the workbook. Unfortunately, after comboboxes code was added, the Workbook_SheetChange code stopped working. I assume it is because it cannot find Target in data validation/combobox cell now.
The second issue is that the Worksheet_SelectionChange code below causes screen flickering even though Application.ScreenUpdating is applied. Is there any way to get rid of it?
I would be greatful for any solutions.
EDIT:
At last I managed to find solution to first issue myself. I ommited Workbook_SheetChange event entirely and replaced with ComboShtHeader_KeyDown and ComboShtHeader_LostFocus events, both placed in the workbook sheets. These macros ensure that value of a cell changes on all sheets either on pressing Tab, Enter or click outside "D4" cell. I am placing both codes below for the case that someone faces similar issue.
The other issue with screen flickering in Worksheet_SelectionChange code persists though. Solutions are still welcome.:-)
Private Sub ComboShtHeader_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'change "D4" cell value on all sheets on pressing TAB or ENTER
Dim ws1 As Worksheet, ws As Worksheet
Set ws1 = ActiveSheet
Select Case KeyCode
Case 9 'Tab
ActiveCell.Offset(0, 1).Activate
For Each ws In Worksheets
If ws.Name <> ws1.Name Then
ws.Range(ActiveCell.Offset(0, -3).Address).Value = ActiveCell.Offset(0, -3).Value
End If
Next ws
Case 13 'Enter
ActiveCell.Offset(1, 0).Activate
For Each ws In Worksheets
If ws.Name <> ws1.Name Then
ws.Range(ActiveCell.Offset(-1, 0).Address).Value = ActiveCell.Offset(-1, 0).Value
End If
Next ws
Case Else
'do nothing
End Select
End Sub
Private Sub ComboShtHeader_LostFocus()
'change "D4" cell value on all sheets on click outside "D4" cell
Dim ws1 As Worksheet, ws As Worksheet
Set ws1 = ActiveSheet
For Each ws In Worksheets
If ws.Name <> ws1.Name Then
ws.Range("D4").Value = ws1.Range("D4").Value
End If
Next ws
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ws As Worksheet, ws2 As Worksheet
Dim ComHead As OLEObject, ComBody As OLEObject
Dim Str As String
Application.ScreenUpdating = False
On Error GoTo ErrHandler
Set ws = ActiveSheet
Set ws2 = Worksheets("lists")
Set ComHead = ws.OLEObjects("ComboShtHeader")
Set ComBody = ws.OLEObjects("ComboShtBody")
On Error Resume Next
If ComHead.Visible = True Then
With ComHead
.Top = 34.5
.Left = 120
.Width = 20
.Height = 15
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With
End If
On Error Resume Next
If ComBody.Visible = True Then
With ComBody
.Top = 34.5
.Left = 146.75
.Width = 20
.Height = 15
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With
End If
On Error GoTo ErrHandler
'If the cell contains a data validation list
If Target.Validation.Type = 3 Then
If Target.Address = ws.Range("D4:F4").Address Then
If Target.Count > 3 Then GoTo ExitHandler
Application.EnableEvents = False
'Get the data validation formula
Str = Target.Validation.Formula1
Str = Right(Str, Len(Str) - 1)
With ComHead
'Show the combobox with the validation list
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 15
.Height = Target.Height
.ListFillRange = ws2.Range(Str).Address(external:=True)
.LinkedCell = Target.Address
End With
ComHead.Activate
'Open the dropdown list automatically
Me.ComboShtHeader.DropDown
Else
If Target.Count > 1 Then GoTo ExitHandler
Application.EnableEvents = False
'Get the data validation formula
Str = Target.Validation.Formula1
Str = Right(Str, Len(Str) - 1)
With ComBody
'Show the combobox with the validation list
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 15
.Height = Target.Height
.ListFillRange = ws2.Range(Str).Address(external:=True)
.LinkedCell = Target.Address
End With
ComBody.Activate
'Open the dropdown list automatically
Me.ComboShtBody.DropDown
End If
End If
ExitHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
ErrHandler:
Resume ExitHandler
End Sub
The second code, placed in ThisWorkbook module and currently not working:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim wb1 As Workbook
Dim ws1 As Worksheet, ws As Worksheet
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set wb1 = ThisWorkbook
Set ws1 = Sh
On Error GoTo LetsContinue
'This should change "D4" value on all sheets, but does not work after combobox feature was added to the sheets.
If Not Intersect(Target, ws1.Range("D4")) Is Nothing Then
MsgBox Target.Address 'returns nothing
For Each ws In wb1.Worksheets
If Target.Value <> ws.Range(Target.Address).Value Then
ws.Range(Target.Address).Value = Target.Value
End If
Next ws
Else
GoTo LetsContinue
End If
LetsContinue:
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Actually, the second issue that regarded screen flickering solved itself when I moved from Excel 2007 to 2013 version. It seems like some kind of bug in older version.