Posts by jsmith2043

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)


    If Worksheets("Sheet1").Range("F3").Value = "Yes" Then
        Sheets("Sheet2").Visible = True
    Else
        Sheets("Sheet2").Visible = False
    End If
    




End Sub

With OutMail  
    .To = ""
    .Cc = ""
     '.BCC = ""
    .Subject = ""
    .Body = ""
    .Attachments.Add ActiveWorkbook.FullName
    .Display
    




End With

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)Dim rng1 As Range
Dim rng2 As Range




Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If ActiveSheet.Name = "Dept1" Then 'change name of sheet as needed
     'Resume to next line if any error occurs
    On Error Resume Next
    Dim cell As Range
    With ActiveSheet
       .Unprotect Password:="open"
        For Each cell In ActiveSheet.UsedRange
        Set rng1 = Intersect(Cells.SpecialCells(xlFormulas), Cells.SpecialCells(xlBlanks))
        Set rng2 = Intersect(Cells.SpecialCells(xlConstants), Cells.SpecialCells(xlBlanks))
        ActiveSheet.UsedRange.Locked = False
    If Not rng1 Is Nothing Then rng1.Locked = True
    If Not rng2 Is Nothing Then rng2.Locked = True
    Next cell
        .Protect Password:="open"
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End If








End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)Dim rng1 As Range
Dim rng2 As Range
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If ActiveSheet.Name = "Sheet1" Then 'change name of sheet as needed
     'Resume to next line if any error occurs
    On Error Resume Next
    Dim Cell As Range
    With ActiveSheet
         'First of all unprotect the entire sheet
        .unprotect Password:=""
         'Now search for non blank cells and lock them and unlock blank cells
        For Each Cell In ActiveSheet.UsedRange
           Set rng1 = Intersect(Cells.SpecialCells(xlFormulas), Cells.SpecialCells(xlBlanks))
           Set rng2 = Intersect(Cells.SpecialCells(xlConstants), Cells.SpecialCells(xlBlanks))
            ActiveSheet.UsedRange.Locked = False
    If Not rng1 Is Nothing Then rng1.Locked = True
    If Not rng2 Is Nothing Then rng2.Locked = True
                End If
            End If
        Next Cell
         'Protect with blank password, you can change it
        .Protect Password:=""
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End If
End Sub

Option ExplicitPrivate Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim i As Long
    Dim j As Long
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    If ActiveSheet.Name = "Sheet1" Then 'change name of sheet as needed
         'Resume to next line if any error occurs
        On Error Resume Next
        Dim Cell As Range
        With ActiveSheet
             'First of all unprotect the entire sheet
            .Unprotect Password:=""
             'Now search for non blank cells and lock them and unlock blank cells
            For Each Cell In ActiveSheet.UsedRange
                i = Cell.Row
                j = Cell.Column
                If Cell.Value <> "" Then
                    If Cell.Locked = False Then
                        Cell.Locked = True
                    End If
                End If
            Next Cell
             'Protect with blank password, you can change it
            .Protect Password:=""
        End With
        Application.Calculation = xlCalculationAutomatic
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End If
End Sub

Sub CopyData()Dim k As Long, v As Long
Dim copyRange As Range
Dim dataSet As Variant
Dim wsReport As Worksheet
Dim ws As Worksheet
Dim lastRow As Long
On Error GoTo ErrHandler
Application.ScreenUpdating = False








Set ws = Worksheets("Tool Room List")
Set wsReport = Worksheets("Report")
wsReport.Select
v = Cells(Rows.Count, "A").End(xlUp).Row + 2
If v = 1 And Range("A1") = vbNullString Then
Else
v = Cells(Rows.Count, "A").End(xlUp).Row + 3
End If
Worksheets("Report").Unprotect Password:="open"
newReportStart = v
ws.Select
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For k = 14 To lastRow
If Range("G" & k) > 0 Then
Set copyRange = Range("A" & k & ":M" & k)
dataSet = copyRange
wsReport.Select
Range("C" & v) = dataSet(1, 1)
Range("B" & v) = dataSet(1, 3)
Range("A" & v) = dataSet(1, 4)
Range("D" & v) = dataSet(1, 7)
Range("H" & v) = Format(Now, "mm/dd/yy hh:mm")
Range("G" & v) = dataSet(1, 11)
v = v + 1
End If
ws.Select
Next
wsReport.Select
'sort the data
Range("A" & newReportStart & ":E" & Cells(Rows.Count, "A").End(xlUp).Row).Select
   Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal








setborder
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "The Error Number is - " & Err.Number & ": " & Err.Description
MsgBox "Unable to continue"




End Sub












Sub setborder()
Worksheets("Report").Select
Columns("A:A").ColumnWidth = 45.43
 Range("A" & newReportStart & ":H" & Cells(Rows.Count, "A").End(xlUp).Row).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .Weight = xlThin
Worksheets("Report").Protect Password:="open"
    End With
     
    ActiveWorkbook.SendMail Recipients:="[email protected]", Subject:="Tool Request", ReturnReceipt:=False




End Sub