I have some code that is running behind the scenes when an intersection change has been made. I want to protect this sheet as other people will be using it. I need to add to my existing code, something to unprotect every time the script runs and reprotect it once it is done. I'm unsure all the points I need to add it into.
Here is my code thus far, I apologize it is rather lengthy:
Option Explicit
Dim PicturePath As String
Dim StrFile As String
Dim Picturename As String
Dim PasteArea As Range
Dim PicShape As Shape
Dim PDFSheet As Worksheet
Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
Dim CheckRange As Range
Dim SKUCell As Range
'Autofit cell heights*************************************
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Dim StartCell As Range, c As Range, MergeRng As Range, Cell As Range
Dim a() As String, isect As Range, i
'Clear all cells larger than fit area
If Target.Worksheet.Name = ThisWorkbook.Sheets("General").Name Then
Cells.Select
Cells.EntireRow.AutoFit
End If
'Take a note of current active cell
Set StartCell = ActiveCell
'Create an array of merged cell addresses that have wrapped text
For Each c In ThisWorkbook.Sheets("General").UsedRange
If c.MergeCells Then
With c.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
If MergeRng Is Nothing Then
Set MergeRng = c.MergeArea
ReDim a(0)
a(0) = c.MergeArea.Address
Else
Set isect = Intersect(c, MergeRng)
If isect Is Nothing Then
Set MergeRng = Union(MergeRng, c.MergeArea)
ReDim Preserve a(UBound(a) + 1)
a(UBound(a)) = c.MergeArea.Address
End If
End If
End If
End With
End If
Next c
Application.ScreenUpdating = False
'Loop thru merged cells
For i = 0 To UBound(a)
Range(a(i)).Select
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
'Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
MergedCellRgWidth = 0
Next i
StartCell.Select
Application.ScreenUpdating = True
'Clean up
Set CurrCell = Nothing
Set StartCell = Nothing
Set c = Nothing
Set MergeRng = Nothing
Set Cell = Nothing
'End Cell Height script***************************************************************************'
'Please change the following settings accordingly:
PicturePath = "P:\Tasting Notes\Images_Data\Labels\"
'ensure picturepath ends with a backslash
If Right(PicturePath, 1) <> "\" Then PicturePath = PicturePath & "\"
If Target.Worksheet.Name = ThisWorkbook.Sheets("General").Name Then
Set PDFSheet = ThisWorkbook.Sheets("General")
Set SKUCell = PDFSheet.Range("m1")
Set PasteArea = PDFSheet.Range("a14:d27")
Set CheckRange = Intersect(Target, SKUCell)
If Not CheckRange Is Nothing Then
'delete existing pictures from table
For Each PicShape In Sheets("General").Shapes
If PicShape.Name = "General" Or PicShape.Name = "BRAND" Then
PicShape.Delete
End If
Next PicShape
'find File in PicturePath Directory
'if the picturename contains the year then use this:
StrFile = Dir(PicturePath & SKUCell.Value & "*.*") 'it will look for a picture named exactly like what is in A1
'if the picturename does not contain the year then you should use this
StrFile = Dir(PicturePath & Left(SKUCell.Value, 6) & "*.*") 'use first 6 digits of PDF only
If StrFile <> "" Then
With PDFSheet.Pictures.Insert(PicturePath & StrFile)
.Name = "General"
'adjust Picturesize - same as cell C3
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Height = 0.9 * PasteArea.Height 'height same as pastearea
.ShapeRange.Width = 0.9 * PasteArea.Width 'width same as pastearea
If .ShapeRange.Height > PasteArea.Height Then 'ensure that if height bigger than cell
.ShapeRange.Height = 0.9 * PasteArea.Height
End If
'left position
.ShapeRange.Left = 0.5 * PasteArea.Width - 0.5 * .ShapeRange.Width
'Top Position
.ShapeRange.Top = PasteArea.Top + 0.5 * (PasteArea.Height - .ShapeRange.Height)
.ShapeRange.Rotation = 0#
End With
Else 'no picture
MsgBox "No Picture found", Title:="Picture Missing"
End If
'Enter Brand picture
Err.Clear
On Error Resume Next
Call InsertBrandLogo(PDFSheet.Range("a10").Value, PDFSheet.Range("a10:d11"))
If Err.Number = 0 Then
Err.Clear
On Error GoTo 0
End If
End If
Set SKUCell = Nothing
Set PDFSheet = Nothing
End If
That is the first half.
Bookmarks