I need users to be able to fill in one row to generate a P.O., and when the P.O. is generated the row below would be unhidden. The P.O. depends on column C, E and G to be filled in.
This code only unhides a row if one of the requirements are met. It also makes the workbook lag.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Row < 14 Or Target.Row > 5000 Or Target.Column < 3 Or Target.Column < 5 Or Target.Column <> 7 Then GoTo ExitMe
Rows(Target.Row + 1).Hidden = False
ExitMe:
Application.EnableEvents = True
End Sub
I need one row to be filled in at a time so the P.O. can be generated properly. If there is a better way please let me know.
This macro also conflicts with my macro for protecting changed cells when the worksheet is saved. This is the error that appears: Run-time error '1004': Unable to set hidden property of the Range class.
It is placed in ThisWorkbook
Option Explicit
Private bRangeEdited As Boolean
Private WithEvents ws As Worksheet
Private Sub Workbook_Open()
Set ws = Range("A14:Y3000").Parent
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim sMSG As String
sMSG = "saving the workbook will lock the cells you have entered data into." & vbLf
sMSG = sMSG & "Do you want to go ahead ?"
If Not bRangeEdited Then GoTo Xit
If Not Me.ReadOnly Then
With Range("A14:Y3000")
If MsgBox(sMSG, vbExclamation + vbYesNo) = vbNo Then
Cancel = True
GoTo Xit
End If
.Parent.Unprotect "password"
If .SpecialCells(xlCellTypeBlanks).Address <> .Address Then
.SpecialCells(xlCellTypeConstants).Locked = True
bRangeEdited = False
End If
.Parent.Protect "password"
End With
End If
Xit:
End Sub
Private Sub ws_Change(ByVal Target As Range)
If Not Intersect(Range("A14:Y3000"), Target) Is Nothing Then
bRangeEdited = True
End If
End Sub
Related
Any chance of getting help combining the two below codes?
I'll try to educate myself on combining these things as I'm sure it's not that complicated, but for now I'd appreciate any assistance.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.CutCopyMode = False Then
Application.Calculate
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim UndoList As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
On Error GoTo ErrExit
UndoList = Application.CommandBars("Standard").Controls("&Undo").List(1)
If Left(UndoList, 5) = "Paste" Or UndoList = "Auto Fill" Then
MsgBox "Copy / paste is not permitted" & vbCr & _
"- Creator"
With Application
.Undo
.CutCopyMode = False
End With
Target.Select
End If
'The UperCase part______________________________________________
If Not (Application.Intersect(Target, Range("E8:OF57")) _
Is Nothing) Then
With Target
If Not .HasFormula Then
Application.EnableEvents = False
.Value = UCase(.Value)
Application.EnableEvents = True
End If
End With
End If
'_______________________________________________________________
ErrExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
I'm trying to make my workbook as easy to use as possible, and to avoid user mistakes that mess upp formulas and so forth.
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Dim MyPicture As Object
Dim MyTop As Double
Dim MyLeft As Double
Dim TopRightCell As Range
'-----------------------------------------------------------
'- top right cell
With ActiveWindow.VisibleRange
r = 1
c = .Columns.Count
Set TopRightCell = .Cells(r, c)
End With
'------------------------------------------------------------
'- position picture
Set MyPicture = ActiveSheet.Pictures(1)
MyLeft = TopRightCell.Left - MyPicture.Width - 200
With MyPicture
.Left = MyLeft
End With
End Sub
The line starting with Private Sub or Sub begins the macro, and the line End Sub is the end of the macro.
Of the two code blocks you've pasted, the top contains two macros (one Worksheet_SelectionChange and one Worksheet_Change), and the second block only contains a SelectionChange one.
Depending which of those you wish to merge, just cut-paste the code from the inside of one sub (i.e. not including the start and end lines Private Sub and End Sub) into another, to make an amalgamated sub containing both sets of code. You may wish to amalgamate all three, but I'd guess it's just the two SelectionChange subs you want to merge.
I am trying to automatically lock cells after user has hit save button. The sheets is protected and contains some unlocked cells where user can input data.
Now I want those cells to get locked after user has clicked data. I have multiple sheets in the workbook but I want this to happen just for the first sheet.
Option Explicit
Dim Ws As Worksheet
Private bRangeEdited As Boolean
'Private WithEvents Ws As Worksheet
Private Sub Workbook_Open()
Set Ws = Range("A1:ZZ27").Parent
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim sMSG As String
sMSG = "Beim Speichern der Arbeitsmappe werden die Eingabezellen gesperrt. " & vbLf
sMSG = sMSG & "Möchten Sie fortfahren ?"
If Not bRangeEdited Then GoTo Xit
If Not Me.ReadOnly Then
With Range("A1:ZZ27")
If MsgBox(sMSG, vbExclamation + vbYesNo) = vbNo Then
Cancel = True
GoTo Xit
End If
Unpro_SheeTS
' .Parent.Unprotect "1234"
If .SpecialCells(xlCellTypeBlanks).Address <> .Address Then
.SpecialCells(xlCellTypeConstants).Locked = True
bRangeEdited = False
End If
Pro_SheeTS
' .Parent.Protect "1234"
End With
End If
Xit:
End Sub
Private Sub ws_Change(ByVal Target As Range)
Dim Ws As Worksheet
If Not Intersect(Range("A1:ZZ27"), Target) Is Nothing Then
bRangeEdited = True
End
End Sub
Sub Unpro_SheeTS()
For Each Ws In ActiveWorkbook.Worksheets
Ws.Unprotect ("1234")
Next
Exit Sub
End Sub
Sub Pro_SheeTS()
For Each Ws In ActiveWorkbook.Worksheets
Ws.Protect ("1234")
Next
Exit Sub
End Sub
My guess is that you should have a worksheet_change event function which keeps track of what cell is modified in a list/array/collection as you feel.
On the other hand your Workbook_BeforeSave event would go through the sheets you want and for each of them it would unprotect the sheet, lock the cells (worksheet.range(...).locked = true) then protects the sheet.
(You dont need to protect the workbook for your purpose, it is a different matter)
for you to have better results :
indent your code
refer to ranges from a worksheet explicitly
(worksheet.range)
consider migrating to another language ;)
Unfortunately Worksheet_change is not working for me. I am using a Sheet where the first column is NOW() function. If I click anywhere in the excel the time on this cell changes, but the Worksheet_Change just don't detect it.
A2 is using =NOW()
Anyone knows how to fix this issue? I have tried several different ways and no one works.
'Option Explicit
'Option Base 1
Dim xVal As Double
'Update by Extendoffice 2018/8/22
'Private Sub Worksheet_Calculate(ByVal Target As Range)
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Address = Range("$A$2").Address Then
'Rows(3).Insert Shift:=xlDown
'Range("$A$3").Value = Now
'Range("$B$3").Value = xVal
'Range("$C$3").Value = Range("$C$2").Value
'Else
If xVal <> Range("$B$2").Value Then
Debug.Print xVal & " <- xVal IF"
Debug.Print Range("B2").Text & "<- Text IF"
Rows(3).Insert Shift:=xlDown
Range("$A$3").Value = Now
Range("$B$3").Value = xVal
Range("$C$3").Value = Range("$C$2").Value
End If
End If
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
xVal = Range("$B$2").Value
End Sub
A Worksheet_Calculate Event Study
Google Drive
Cell A2 in worksheet Sheet1 contains the formula =B2.
Sheet1
Option Explicit
Private Sub Worksheet_Calculate()
WsCalc
End Sub
' Only to trigger the calculate event when different cell is selected.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ThisWorkbook.Worksheets("Sheet1").Range("B2") = Int(Rnd() * 2 + 1)
End Sub
ThisWorkbook
Option Explicit
Private Sub Workbook_Open()
WsCalc
End Sub
Module1
Option Explicit
Public lngSource As Long ' Current Source Value
Sub WsCalc()
Dim rngSource As Range ' Source Cell Range
' Create a reference to Source Cell Range (rngSource).
Set rngSource = ThisWorkbook.Worksheets("Sheet1").Range("A2")
' When the workbook opens, Current Source Valuec (lngSource) is equal to "".
' Therefore:
If lngSource = 0 Then
' Initialize Current Source Value (lngSource) i.e. write value
' of Source Cell Range (rngSource) to Current Source Value (lngSource).
lngSource = rngSource.Value
MsgBox "Monitoring started (lngSource=" & lngSource & ")."
Exit Sub
End If
' If you need disabling events, this is how you implement it. Not needed
' in this code.
' Application.EnableEvents = False
On Error GoTo ProgramError
' Check value of Source Cell Range (rngSource)
' against Current Source Value (lngSource).
If rngSource.Value <> lngSource Then
' The value has changed.
MsgBox "The value has changed from '" & lngSource & "' to '" _
& rngSource.Value & "'."
lngSource = rngSource.Value
Else
' The value hasn't changed (usually no code).
MsgBox "Value NOT changed, still '" & lngSource & "'"
End If
SafeExit:
' MsgBox "Enabling events before exiting."
' Application.EnableEvents = True
Exit Sub
ProgramError:
' Improve this error handling.
MsgBox "An unexpected error occurred."
On Error GoTo 0
GoTo SafeExit
End Sub
I'm currently working on a set of code that locks and unlocks a sheet based on the username of the current user, nothing fancy. This code works quite well, except during the after save portion. Intermittently, when saved on the company server, on my computer only (though its only been lightly tested on 3 computers), I get a 50290 error with anything that tries to modify the sheet - even application.wait. Eventually I traced this to the workbook not being ready (application.ready returns false after save, but true if I manually run the code or during the open workbook event). It seems that the standard procedure is to do while loop until application.ready = true, but that locks the computer up with no recovery. I've tried methods of slowing the loop down (sleep, doevent, wait) and none of those seem to fix the issue.
Any ideas?
Sub AuthorizedUser()
- initialize variables here
On Error GoTo errorhandler
Do 'attempt to wait until sheet is ready
DoEvents
Loop Until Application.Ready = True
- Do stuff to protect sheet here -
- If the sheet isn't ready, error state -
- Any change, such as application.wait, coloring cells, or protecting sheet is what the error state occurs on -
errorhandler:
MsgBox "Unlocker broke. Please hit the unlock button"
End Sub
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Call AuthorizedUser
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
- do stuff to protect worksheet -
End Sub
Private Sub Workbook_Open()
Call AuthorizedUser
Application.Run "sheet1.ClearSheet"
End Sub
editted to remove the inner workings of the code. This code works just fine when excel is ready and does things as intended.
Let me know how this one works for you. If it works and you want it, I can make a list of the changes that I made
Option Explicit
Private Const THE_PASSWORD As String = "TDM"
Private Sub Auto_Open()
Call AuthProtect(False)
ThisWorkbook.Sheets(1).Cells.Clear
End Sub
Private Function GetAuth() As Long
With ThisWorkbook.Sheets("Authorized users")
Dim managers As Range
Set managers = .Range("A1").Resize(.Range("A1").End(xlDown).Row)
Dim workers As Range
Set workers = .Range("B1").Resize(.Range("B1").End(xlDown).Row)
End With
On Error GoTo errorhandler
While Not Application.Ready
DoEvents
Wend
On Error GoTo 0
Dim currentUser As String
currentUser = Environ$("username")
Dim auth As Long
Dim cell As Range
For Each cell In Union(managers, workers)
If LCase$(currentUser) = LCase$(cell.Value2) Then
auth = cell.Column
Exit For
End If
Next cell
GetAuth = auth
Exit Function
errorhandler:
GetAuth = -1
End Function
Private Sub AuthProtect(ByVal doProtect As Boolean)
On Error GoTo errorhandler
SpeedUp True
If doProtect Then
With ThisWorkbook
.Unprotect THE_PASSWORD
With .Sheets("Authorized users")
.Unprotect THE_PASSWORD
.Columns("B").Locked = True
.Protect THE_PASSWORD
.Visible = xlVeryHidden
End With
With .Sheets("Part Tracker")
.Unprotect THE_PASSWORD
.Rows("6:" & Rows.Count).Locked = True
.Protect THE_PASSWORD
End With
.Protect THE_PASSWORD
End With
Else
Select Case GetAuth
Case 1
With ThisWorkbook
.Unprotect THE_PASSWORD
With .Sheets("Authorized users")
.Visible = xlSheetVisible
.Unprotect THE_PASSWORD
.Columns("B").Locked = False
.Protect THE_PASSWORD
End With
.Protect THE_PASSWORD
End With
Case 2
With ThisWorkbook.Sheets("Part Tracker")
.Unprotect THE_PASSWORD
.Rows("6:" & Rows.Count).Locked = False
.Protect THE_PASSWORD, _
AllowInsertingRows:=True, _
AllowInsertingHyperlinks:=True, _
AllowDeletingRows:=True, _
AllowFiltering:=True, _
UserInterfaceOnly:=True, _
DrawingObjects:=False
.EnableOutlining = True
End With
Case -1
MsgBox "Error with Application.Ready state"
Case Else
With ThisWorkbook.Sheets("Authorized users")
Dim managers As Range
Set managers = .Range("A1").Resize(.Range("A1").End(xlDown).Row)
End With
Dim managerList As String
Dim cell As Range
For Each cell In managers
managerList = managerList & " " & cell.Value2 & vbCrLf
Next cell
MsgBox "You do not have write access to this file." & vbNewLine & "To request access, please seek out any of the following managers: " & vbCrLf & vbCrLf & managerList
End Select
End If
errorhandler:
SpeedUp False
End Sub
Sub SpeedUp(ByVal toggleOn As Boolean)
With Application
.Calculation = IIf(toggleOn, xlCalculationManual, xlCalculationAutomatic)
.ScreenUpdating = Not toggleOn
.DisplayStatusBar = Not toggleOn
.EnableEvents = Not toggleOn
End With
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Call AuthProtect(True)
End Sub
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Call AuthProtect(False)
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call AuthProtect(True)
End Sub
I have an invoice set up with validation list on a separate worksheet listing all our parts we sell. I put combo boxes on the invoice and linked them to the validation list and included code so that when box is double clicked, it will start auto completing the box using the validation list when typed. I also included code so that when this invoice is closed at end of the day, and then reopened the next day, or when shortcut key is pressed, it will clear the contents and change the invoice number.
Sometimes I need to save a, invoice to add on or change later. So I copy that worksheet and rename it with customer name. This has worked fine for over a year. But last week, when I click on any cell on the copied worksheets, it has a runtime error 1004 Method "OLEObjects" of object"_Worksheet" failed. Then the combo boxes don't work. But it only does it on the copied worksheets. The original worksheet works fine. Any suggestions? Here is the code used:
'==========================
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Dim wsList As Worksheet
Set ws = ActiveSheet
Set wsList = Sheets("ValidationLists")
Cancel = True
Set cboTemp = ws.OLEObjects("Parts")
On Error Resume Nex
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
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
End If
errHandler:
Application.EnableEvents = True
Exit Sub
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
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("Parts")
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
Private Sub Parts_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
Set cboTemp = ws.OLEObjects("Parts") is where the problem is. It appears twice and gets flagged on both of them.