none
Data validation error box will not display RRS feed

  • Question

  • I am adding data validation to some Excel VBA code. I have literally copied and pasted the block of data validation from another project, and it functions fine there.  Here, in the file, when I type bad data in the cell(s), it just clears the cell without the MsgBox.  

    In fact, the data validation will not display the error MsgBox anywhere in the file, or will not display in any file if this file is open. However, the data validation MsgBox will display as expected if this file is not open. 

    Here is the block in question:

                    With Selection.Validation
                        .Delete
                        .Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, _
                        Operator:=xlBetween, Formula1:="0", Formula2:="999999999999999999999"
                        .InputMessage = "Enter Positive Whole Numbers Only"
                        .ErrorTitle = "Whole Numbers Only"
                        .ErrorMessage = "Only Enter Positive Whole Numbers." & vbCrLf & vbCrLf & _
                        "Please put additional information in the ""Cust. Notes"" column."
                        .ShowInput = True
                        .ShowError = True
                    End With

    here is the entire sub (just in case I did something dumb in there later)

    '************************************************************************************************
    '*                                                                                              *
    '*CGA00:                ANNUAL AVAILABILITY FORMAT                                              *
    '*                                                                                              *
    '************************************************************************************************
    
    Sub Annual_Avail_Format()
    
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    'CGA01: INITIALIZE
    
        'determine if test or prod
        Workbooks("Tally Sheet.xlsm").Activate
        Sheets("definition_table").Visible = xlSheetVisible
        Sheets("definition_table").Activate
        test = Cells(4, 3)
        Sheets("tally_sheet").Activate
        Sheets("definition_table").Visible = xlSheetHidden
        Cells(1, 1).Select
    
        'open unformatted annual availability
        tempfilepath = Application.GetOpenFilename
        Workbooks.Open (tempfilepath)
        tempfile = PathToName(tempfilepath)
        Workbooks(tempfile).Activate
    
        
    'CGA02: COPY SHEET IF TESTING (SO DON'T HAVE TO KEEP EXTRACTING FILES FROM GROWPOINT)
    
        'if testing, check if "Ann_Avail" sheet already exists, if so delete then copy sheet1 to new
        'sheet and name it "Ann_Avail"
        If test = True Then
            flg = False
            For Each sh In Worksheets
                If sh.Name = "Ann_Avail" Then flg = True: Exit For
            Next
            If flg = True Then
                Worksheets("Ann_Avail").Delete
                Else
            End If
            
            Worksheets("Sheet1").Select
            Application.CutCopyMode = True
            Cells.Select
            Selection.Copy
            Worksheets.Add
            ActiveSheet.Name = "Ann_Avail"
            Range("a1").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
            Sheets("Ann_Avail").Select
        
        'if prod, rename sheet1 to "Ann_Avail"
        Else
            ActiveSheet.Name = "Ann_Avail"
        End If
    
    '************************************************************************************************
    '*                                                                                              *
    '*CGB00:                PRELIMINARY SETUP                                                       *
    '*                                                                                              *
    '************************************************************************************************
    
        'set cell lock attributes to true. Individual cells are unlocked when formatting is set
        Range("a1").Select
        Cells.Select
        Range("a1").Activate
        Selection.Locked = True
        Selection.FormulaHidden = False
    
        'remove all shading
        With Selection
            .Interior.ColorIndex = xlNone
        End With
    
        'change font and point size
        Cells.Select
        With Selection.Font
            .Name = "univers extended"
            .Size = 11
            .Color = RGB(0, 0, 0)
        End With
    
        'change row height, vertical alignment and font size for entire sheet
        With Selection
            .RowHeight = 15
            .VerticalAlignment = xlTop
        End With
    
        'get list name text
        txtstr = Cells(2, 3)
        newstr = cutstr(txtstr)
        listname = newstr
        If InStr(1, listname, "Excel ", vbTextCompare) > 0 Then
            listname = Right(listname, Len(listname) - 6)
        End If
    
        'get "week of" availibility text
        txtstr = Cells(4, 3)
        newstr = cutstr(txtstr)
        weekof = newstr
        If InStr(1, weekof, "Availability ", vbTextCompare) > 0 Then
            weekof = Right(weekof, Len(weekof) - 13)
        End If
    
        'get note 1 text
        note1 = Cells(3, 3)
    
        'get note 2 text
        note2 = Cells(5, 3)
    
        'format blank header
        Rows("1:7").Select
        Range("A1").Activate
        Selection.Delete Shift:=xlUp
        Rows("1:1").Select
        Range("B1").Activate
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
        'format row 7 (column headers)
        Range("A7") = "Item Key"
        Range("B7") = "Group"
        Range("C7") = "Variety"
        Range("D7") = "Size"
        Range("E7") = "Price"
        Range("F7") = "Order Qty"
        Range("G7") = "Total"
        Range("H7") = "Avail."
        Range("I7") = "Desc."
        Range("J7") = "Cust. Notes"
        Range("K7") = "Item Description"
        Range("L7") = "Office Use"
        Range("A7:L7").Select
        Range("b7").Activate
        Range(Cells(7, 1), Cells(7, 12)).Select
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection
            .Interior.Color = RGB(142, 151, 238)
            .Font.Bold = True
            .Font.Color = RGB(0, 0, 0)
            .Font.Size = 12
            .RowHeight = 31.5
            .HorizontalAlignment = xlGeneral
            .VerticalAlignment = xlBottom
            .WrapText = True
        End With
    
    '************************************************************************************************
    '*                                                                                              *
    '*CGC00:                FORMAT HEADER (ROW 1-6) FOR SCREEN OPTIMIZATION                         *
    '*                                                                                              *
    '************************************************************************************************
    
        'set row heights
        Rows("1:1").RowHeight = 30
        Rows("2:2").RowHeight = 15
        Rows("3:3").RowHeight = 16.5
        Rows("4:4").RowHeight = 28.5
        If Len(note1) = 0 Then
            Rows("5:5").RowHeight = 0
            Else
            Columns("P:P").ColumnWidth = 147
            Cells(5, 16) = note1
            Rows("5:5").WrapText = True
            Rows("5:5").EntireRow.AutoFit
            row5height = Rows("5:5").RowHeight
        End If
            If Len(note2) = 0 Then
            Rows("6:6").RowHeight = 0
            Else
            Columns("P:P").ColumnWidth = 147
            Cells(6, 16) = note2
            Rows("6:6").WrapText = True
            Rows("6:6").EntireRow.AutoFit
            row6height = Rows("6:6").RowHeight
        End If
        Columns("P:P").Delete Shift:=xlToLeft
    
    
        'Merge Cells, borders, and unlock cells
        Range("B1", "I1").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
        End With
    
        Range("B2", "I2").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
        End With
    
        Range("B3", "I3").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
        End With
    
        Range("B4", "E4").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
        End With
    
        Range("F4", "I4").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlTop
        End With
    
        Range("K1", "L1").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeTop).Weight = xlThin
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).Weight = xlThin
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).Weight = xlThin
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlEdgeRight).Weight = xlThin
            .Locked = False
        End With
    
        Range("K2", "L3").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeTop).Weight = xlThin
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).Weight = xlThin
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).Weight = xlThin
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlEdgeRight).Weight = xlThin
            .Locked = False
        End With
    
        Range("K4", "L4").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeTop).Weight = xlThin
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).Weight = xlThin
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).Weight = xlThin
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlEdgeRight).Weight = xlThin
            .Locked = False
        End With
    
        Range("B5", "L5").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
    
        Range("B6", "L6").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
    
        'header text
        Range("B1", "I1").Select
        ActiveCell = "Quality Greenhouses & Perennial Farm, Inc."
        With Selection.Font
            .Size = 24
        End With
    
        Range("B2", "I2").Select
        ActiveCell = "250 Union Church Rd, Dillsburg PA 17019     Phone: (717) 432-8900      " & _
        "Fax: (717) 502-8906"
        With Selection.Font
            .Size = 12
        End With
    
        Range("B3", "I3").Select
        ActiveCell = "Send Orders to: Orders@qualitygreenhouses.net"
        With Selection.Font
            .Size = 12
        End With
    
        Range("B4", "E4").Select
        ActiveCell = weekof
        With Selection.Font
            .Color = RGB(255, 0, 0)
            .Size = 16
            .Bold = True
        End With
    
        Range("F4", "I4").Select
        ActiveCell = listname
        With Selection.Font
            .Size = 16
            .Bold = True
        End With
    
        Cells(1, 10) = "Customer:"
        Cells(2, 10) = "Contact:"
        Cells(4, 10) = "Req. Ship Dt. / Delivery Notes:"
        Cells(4, 10).WrapText = True
        Cells(5, 2) = note1
        Rows("5:5").RowHeight = row5height
        Cells(5, 3).WrapText = True
        Cells(6, 2) = note2
        Rows("6:6").RowHeight = row6height
        Cells(6, 2).WrapText = True
    
    '************************************************************************************************
    '*                                                                                              *
    '*CGD00:                FORMAT DATA (ROW 7-EOF) FOR SCREEN OPTIMIZATION                         *
    '*                                                                                              *
    '************************************************************************************************
    
        'set auto filter on headings
        Range(Cells(7, 1), Cells(7, 12)).Select
        Selection.AutoFilter
    
        'find end of file
        arow = 8
        acol = 2
        Do
            Cells(arow, acol).Select
            arow = arow + 1
        Loop Until ActiveCell.Offset(1, 0) = ""
    
        brow = 8
        bcol = 3
    
        'row format loop
        Do
    
            'underline each row
            Range(Cells(brow, 1), Cells(brow, 12)).Select
            With Selection.Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
    
            'if column C = "Variety" row is section header
            Cells(brow, bcol).Select
            If ActiveCell = "Variety" Then
                sectionheader = True
                colorrow = False
                Else
                sectionheader = False
            End If
    
            If ActiveCell.Offset(0, -2) = "" Then
                sectionheader = True
                colorrow = False
            End If
    
            Select Case sectionheader
    
                'format section header row
                Case True
                    'if row below section header is info, move info, mark row to delete
                    If ActiveCell.Offset(1, -2) = "" Then
                        ActiveCell.Offset(1, -2) = "delete"
                        headercmt = ActiveCell.Offset(1, 0)
                    End If
                    
                    Range(Cells(brow, 1), Cells(brow, 12)).Select
                    With Selection
                        .Interior.Color = RGB(255, 255, 204)
                        .Font.Bold = True
                    End With
                    
                    Range(Cells(brow, 3), Cells(brow, 12)).Select
                    With Selection
                        .Merge = True
                        .HorizontalAlignment = xlLeft
                        .WrapText = True
                    End With
                    
                    If ActiveCell.Offset(1, -2) = "delete" Then
                        ActiveCell = headercmt
                    End If
                    
        
    
                'format item row
                Case False
    
                    'format group remove extra spaces
                    txtstr = Cells(brow, 2)
                    newstr = cutstr(txtstr)
                    Cells(brow, 2) = newstr
    
                    'shade every other row for readability
                    If ActiveCell.Offset(0, -2) = "delete" Then GoTo skipcolor
                    Select Case colorrow
                        Case True
                            Range(Cells(brow, 1), Cells(brow, 12)).Select
                            With Selection.Interior
                                .Color = RGB(229, 231, 251)
                            End With
                            colorrow = False
    
                       Case False
                            colorrow = True
                    End Select
    skipcolor:
    
                'text format for "size" column
                txtstr = Cells(brow, 4)
                newstr = cutstr(txtstr)
                Cells(brow, 4) = newstr
                Cells(brow, 4).Select
                With Selection
                    .NumberFormat = "@"
                    .HorizontalAlignment = xlLeft
                End With
    
                'number format for price column
                Cells(brow, 5).Select
                With Selection
                    .NumberFormat = "0.00"
                    .HorizontalAlignment = xlCenter
                End With
    
                'format order qty column - includes data validation
                Cells(brow, 6).Select
                With Selection
                    .Locked = False
                    .FormulaHidden = False
                    .HorizontalAlignment = xlCenter
                    .Font.Bold = True
                    .NumberFormat = "0"
                End With
                
                With Selection.Validation
                    .Delete
                    .Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, _
                    Operator:=xlBetween, Formula1:="0", Formula2:="999999999999999999999"
                    .InputMessage = "Enter Positive Whole Numbers Only"
                    .ErrorTitle = "Whole Numbers Only"
                    .ErrorMessage = "Only Enter Positive Whole Numbers." & "Please put additional information in the ""Cust. Notes"" column."
                    .ShowInput = True
                    .ShowError = True
                End With
                
                With Selection.Borders(xlEdgeLeft)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                
                With Selection.Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                
                With Selection.Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                
                With Selection.Borders(xlEdgeRight)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
    
                'format total column
                Cells(brow, 7).NumberFormat = "0.00"
                Cells(brow, 7).HorizontalAlignment = xlCenter
    
                'format customer notes column
                Cells(brow, 10).Select
                Selection.Locked = False
                Selection.FormulaHidden = False
                With Selection.Borders(xlEdgeLeft)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                
                With Selection.Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                
                With Selection.Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                
                With Selection.Borders(xlEdgeRight)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
    
                'if row is comment, merge and lock cells)
                If Cells(brow, bcol - 2) = "" Then
                    Range(Cells(brow, 3), Cells(brow, 12)).Select
                    With Selection
                        .Merge = True
                        .HorizontalAlignment = xlLeft
                        .WrapText = True
                        .Locked = False
                    End With
                End If
    
                'clean up spaces after text in variety column
                If Cells(brow, bcol - 2) <> "" Then
                    If Cells(brow, bcol - 2) <> "delete" Then
                        txtstr = Cells(brow, 3)
                        newstr = cutstr(txtstr)
                        Cells(brow, 3) = newstr
                    End If
                End If
    
                'clean up spaces after text in item description column
                If Cells(brow, bcol - 2) <> "" Then
                    If Cells(brow, bcol - 2) <> "delete" Then
                        txtstr = Cells(brow, 11)
                        newstr = cutstr(txtstr)
                        Cells(brow, 11) = newstr
                    End If
                End If
    
                'clean up spaces after text in office use column
                If Cells(brow, bcol - 2) <> "" Then
                    If Cells(brow, bcol - 2) <> "delete" Then
                        If Cells(brow, 12) = "                                                                                                                             " Then
                            Cells(brow, 12) = ""
                            Else
                            txtstr = Cells(brow, 12)
                            newstr = cutstr(txtstr)
                            Cells(brow, 12) = newstr
                        End If
                    End If
                End If
    
            End Select
    
            'finish loop
            If Cells(brow + 1, brow - 2) = "delete" Then
                brow = brow + 2
                Else
                brow = brow + 1
            End If
        Loop Until brow = arow
    
    
        'set column widths and text wrap
        Cells.VerticalAlignment = xlTop
        Columns("B:B").ColumnWidth = 12.57
        Columns("B:B").WrapText = True
        Columns("C:C").ColumnWidth = 17.71
        Columns("C:C").WrapText = True
        Columns("D:D").ColumnWidth = 9.29
        Columns("D:D").WrapText = True
        Columns("E:E").ColumnWidth = 7.14
        Columns("F:F").ColumnWidth = 7.14
        Columns("G:G").ColumnWidth = 10
        Columns("H:H").ColumnWidth = 11
        Columns("H:H").WrapText = True
        Columns("I:I").ColumnWidth = 11
        Columns("I:I").WrapText = True
        Columns("J:J").ColumnWidth = 14.14
        Columns("K:K").ColumnWidth = 34.86
        Columns("K:K").WrapText = True
        Columns("L:L").ColumnWidth = 6.71
    
        'loop to delete rows marked for deletion and autofit rows not to be deleted
        brow = 8
        bcol = 1
        
        Do
            Cells(brow, bcol).Select
            If ActiveCell = "delete" Then
                Rows(brow).Select
                Selection.Delete Shift:=xlUp
                brow = brow - 1
            Else
                Range(Cells(brow, 1), Cells(brow, 12)).Select
                Selection.Rows.AutoFit
            End If
            
            brow = brow + 1
        
        Loop Until brow = arow
    
    '************************************************************************************************
    '*                                                                                              *
    '*CGE00:                FORMAT PAGE FOR PRINTING                                                *
    '*                                                                                              *
    '************************************************************************************************
    
        'hide item key
        Columns("A:A").EntireColumn.Hidden = True
    
        'page setup for print
        With ActiveSheet.PageSetup
            .PrintTitleRows = "$1:$7"
            .PrintTitleColumns = ""
            .PrintArea = ""
            .Orientation = xlPortrait
            .RightFooter = "Page &P of &N"
            .RightHeader = "Page:_____of_____"
            .LeftMargin = Application.InchesToPoints(0.2)
            .RightMargin = Application.InchesToPoints(0.2)
            .TopMargin = Application.InchesToPoints(0.3)
            .BottomMargin = Application.InchesToPoints(0.3)
            .HeaderMargin = Application.InchesToPoints(0.15)
            .FooterMargin = Application.InchesToPoints(0.15)
            .PrintComments = xlPrintNoComments
            .PrintQuality = 600
            .PaperSize = xlPaperLetter
            .CenterHorizontally = True
            .Zoom = 69
        End With
    
        'freeze panes
        Application.ScreenUpdating = True
        Cells(8, 2).Select
        ActiveWindow.FreezePanes = True
        Application.ScreenUpdating = False
    
        'protect sheet
        Call protect_avail
        
        'create template and sold out list
        Call avail_template_and_sold_out_list
        
    End Sub
    
    '************************************************************************************************
    '************************************************************************************************
    '************************************************************************************************
    '************************************************************************************************
    '************************************************************************************************
    
    
    '************************************************************************************************
    '*                                                                                              *
    '*CHA00:                PERENNIAL AVAILABILITY FORMAT                                           *
    '*                                                                                              *
    '************************************************************************************************
    
    Sub Perennial_Avail_Format()
    
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    'CHA01: INITIALIZE
    
        'determine if test or prod
        Workbooks("Tally Sheet.xlsm").Activate
        Sheets("definition_table").Visible = xlSheetVisible
        Sheets("definition_table").Activate
        test = Cells(4, 3)
        Sheets("tally_sheet").Activate
        Sheets("definition_table").Visible = xlSheetHidden
        Cells(1, 1).Select
    
        'open unformatted perennial availability
        tempfilepath = Application.GetOpenFilename
        Workbooks.Open (tempfilepath)
        tempfile = PathToName(tempfilepath)
        Workbooks(tempfile).Activate
        
    'CHA02: COPY SHEET IF TESTING (SO DON'T HAVE TO KEEP EXTRACTING FILES FROM GROWPOINT)
        
        'if testing, check if "Ann_Avail" sheet already exists, if so delete then copy sheet1 to new
        'sheet and name it "Ann_Avail"
        If test = True Then
            flg = False
            For Each sh In Worksheets
                If sh.Name = "Per_Avail" Then flg = True: Exit For
            Next
            If flg = True Then
                Worksheets("Per_Avail").Delete
                Else
            End If
            Worksheets("Sheet1").Select
            Application.CutCopyMode = True
            Cells.Select
            Selection.Copy
            Worksheets.Add
            ActiveSheet.Name = "Per_Avail"
            Range("a1").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
            Sheets("Per_Avail").Select
            Else
            ActiveSheet.Name = "Per_Avail"
        End If
        
    '************************************************************************************************
    '*                                                                                              *
    '*CHB00:                PRELIMINARY SETUP                                                       *
    '*                                                                                              *
    '************************************************************************************************
    
        'set cell lock attributes to true. Individual cells are unlocked when formatting is set
        Range("a1").Select
        Cells.Select
        Range("a1").Activate
        Selection.Locked = True
        Selection.FormulaHidden = False
        
        'remove all shading
        With Selection
            .Interior.ColorIndex = xlNone
        End With
        
        'change font and point size
        With Selection.Font
            .Name = "univers extended"
            .Size = 11
            .Color = RGB(0, 0, 0)
        End With
        
        'get list name text
        txtstr = Cells(3, 2)
        newstr = cutstr(txtstr)
        listname = newstr
        If InStr(1, listname, "Excel ", vbTextCompare) > 0 Then
            listname = Right(listname, Len(listname) - 6)
        End If
        
        'get note 1 text
        note1 = Cells(4, 2)
        
        'get note 2 text
        note2 = Cells(5, 2)
                
        'get "week of" availibility text
        weekof = Cells(6, 2)
        
        'delete column N - junk info exported from GrowPoint
        Columns("N:N").Select
        Selection.Delete Shift:=xlToLeft
        
        'insert column for total between order qty and availibility
        Columns("H:H").Select
        Selection.Insert Shift:=xlToRight
     
        'format UPC code
        Columns("B:B").Select
        Range("B2").Activate
        Selection.NumberFormat = "0"
        
        'format price
        Columns("F:F").Select
        Range("F2").Activate
        Selection.NumberFormat = "0.00"
        
        'format blank header
        Rows("1:8").Select
        Range("B8").Activate
        Selection.Delete Shift:=xlUp
        Rows("1:1").Select
        Range("B1").Activate
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
     
        'format row 7 (column headers)
        Range("a7") = "Item Key"
        Range("B7") = "UPC"
        Range("C7") = "Group"
        Range("D7") = "Variety"
        Range("E7") = "Size"
        Range("F7") = "Price"
        Range("G7") = "Order Qty"
        Range("H7") = "Total"
        Range("I7") = "Avail."
        Range("J7") = "Desc."
        Range("K7") = "Cust. Notes"
        Range("L7") = "Item Description"
        Range("M7") = "Item Code"
        Range("N7") = "Office Use"
        Range("A7:N7").Select
        Range("b7").Activate
        
        Range(Cells(7, 1), Cells(7, 14)).Select
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        
        With Selection
            .Interior.Color = RGB(198, 224, 180)
            .Font.Bold = True
            .Font.Color = RGB(0, 0, 0)
            .Font.Size = 12
            .RowHeight = 31.5
            .HorizontalAlignment = xlGeneral
            .VerticalAlignment = xlBottom
            .WrapText = True
        End With
        
    '************************************************************************************************
    '*                                                                                              *
    '*CHC00:                FORMAT HEADER (ROW 1-6) FOR SCREEN OPTIMIZATION                         *
    '*                                                                                              *
    '************************************************************************************************
    
        Sheets("Per_Avail").Select
        
        'set row heights
        Rows("1:1").RowHeight = 30
        Rows("2:2").RowHeight = 15
        Rows("3:3").RowHeight = 16.5
        Rows("4:4").RowHeight = 28.5
        If Len(note1) = 0 Then
            Rows("5:5").RowHeight = 0
        Else
            Columns("P:P").ColumnWidth = 147
            Cells(5, 16) = note1
            Rows("5:5").WrapText = True
            Rows("5:5").EntireRow.AutoFit
            row5height = Rows("5:5").RowHeight
        End If
        
        If Len(note2) = 0 Then
            Rows("6:6").RowHeight = 0
        Else
            Columns("P:P").ColumnWidth = 147
            Cells(6, 16) = note2
            Rows("6:6").WrapText = True
            Rows("6:6").EntireRow.AutoFit
            row6height = Rows("6:6").RowHeight
        End If
        
        Columns("P:P").Delete Shift:=xlToLeft
    
        'Merge Cells, borders, and unlock cells
        Range("C1", "J1").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
        End With
        
        Range("C2", "J2").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
        End With
        
        Range("C3", "J3").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
        End With
        
        Range("C4", "F4").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
        End With
         
        Range("G4", "J4").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlTop
        End With
        
        Range("L1", "N1").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeTop).Weight = xlThin
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).Weight = xlThin
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).Weight = xlThin
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlEdgeRight).Weight = xlThin
            .Locked = False
        End With
        
        Range("L2", "N3").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeTop).Weight = xlThin
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).Weight = xlThin
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).Weight = xlThin
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlEdgeRight).Weight = xlThin
            .Locked = False
        End With
        
        Range("L4", "N4").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeTop).Weight = xlThin
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).Weight = xlThin
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).Weight = xlThin
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlEdgeRight).Weight = xlThin
            .Locked = False
        End With
        
        Range("C5", "N5").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
    
        Range("C6", "N6").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
    
        'header text
        Range("C1", "J1").Select
        ActiveCell = "Quality Greenhouses & Perennial Farm, Inc."
        With Selection.Font
            .Size = 24
        End With
        
        Range("C2", "J2").Select
        ActiveCell = "250 Union Church Rd, Dillsburg PA 17019     Phone: (717) 432-8900      " & _
        "Fax: (717) 502-8906"
        With Selection.Font
            .Size = 12
        End With
        
        Range("C3", "J3").Select
        ActiveCell = "Send Orders to: Orders@qualitygreenhouses.net"
        With Selection.Font
            .Size = 12
        End With
        
        Range("C4", "F4").Select
        ActiveCell = weekof
        With Selection.Font
            .Color = RGB(255, 0, 0)
            .Size = 16
            .Bold = True
        End With
        
        Range("G4", "J4").Select
        ActiveCell = listname
        With Selection.Font
            .Size = 16
            .Bold = True
        End With
        
        Range("C5", "N5").Select
        With Selection
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        
        Cells(1, 11) = "Customer:"
        Cells(2, 11) = "Contact:"
        Cells(4, 11) = "Req. Ship Dt. / Delivery Notes:"
        Cells(4, 11).WrapText = True
        Cells(5, 3) = note1
        Rows("5:5").RowHeight = row5height
        Cells(5, 3).WrapText = True
        Cells(6, 3) = note2
        Rows("6:6").RowHeight = row6height
        Cells(6, 3).WrapText = True
        
    '************************************************************************************************
    '*                                                                                              *
    '*CHD00:                FORMAT DATA (ROW 7-EOF) FOR SCREEN OPTIMIZATION                         *
    '*                                                                                              *
    '************************************************************************************************
        
        Sheets("Per_Avail").Select
        
        'set auto filter on headings
        Range(Cells(7, 1), Cells(7, 14)).Select
        Selection.AutoFilter
        
        'hide column a (item key) DO NOT DELETE THIS COLUMN!!!!!!
        Columns("A:A").EntireColumn.Hidden = True
    
        'hide upc and item code per Mary's request
        Columns("B:B").EntireColumn.Hidden = True
        Columns("M:M").EntireColumn.Hidden = True
    
        'find end of file
        arow = 8
        acol = 2
        Do
            Cells(arow, acol).Select
            If ActiveCell.Offset(1, 0) = "                                                                                                                             " Then
                ActiveCell.Offset(1, 0) = "Delete"
            End If
            
            arow = arow + 1
        
        Loop Until ActiveCell.Offset(1, 0) = ""
        
        brow = 8
        bcol = 7
        
        'row format loop
        Do
    
            'determine if row is section header or item
            Cells(brow, bcol).Select
            lengrp = Len(ActiveCell.Offset(0, -4))
            If lengrp > 0 Then
                grp = True 'row is item row
            Else
                grp = False 'row is section header row
                colorrow = False
            End If
            
            Select Case grp
    
                'format section header row
                Case False
                    txtstr = Cells(brow, 2)
                    newstr = cutstr(txtstr)
                    Cells(brow, 2) = newstr
                    Range(Cells(brow, 1), Cells(brow, 14)).Select
                    With Selection
                        .Merge = True
                        .HorizontalAlignment = xlCenter
                        .Interior.Color = RGB(255, 255, 204)
                        .Font.Bold = True
                        .Font.Color = RGB(0, 0, 0)
                        .Font.Size = 12
                    End With
                    
                    Cells(brow, 3) = Cells(brow, 2)
                    Cells(brow, 2) = ""
                    Cells(brow, 3).Font.Bold = True
    
                'format item row
                Case True
                
                    'format group remove extra spaces
                    txtstr = Cells(brow, 3)
                    newstr = cutstr(txtstr)
                    Cells(brow, 3) = newstr
                
                    'shade every other row for readability
                    Select Case colorrow
                        Case True
                            Range(Cells(brow, 1), Cells(brow, 14)).Select
                            With Selection.Interior
                                .Color = RGB(237, 245, 231)
                            End With
                        
                            colorrow = False
    
                        Case False
                            colorrow = True
    
                    End Select
                    
                    'underline each row
                    Range(Cells(brow, 1), Cells(brow, 14)).Select
                    With Selection.Borders(xlEdgeTop)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    
                    With Selection.Borders(xlEdgeBottom)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    
                    'text format for "size" column
                    Cells(brow, 5).Select
                    txtstr = Cells(brow, 5)
                    newstr = cutstr(txtstr)
                    Cells(brow, 5) = newstr
                    Selection.NumberFormat = "@"
        
                    'format number for "price" column
                    Cells(brow, 6).Select
                    Selection.NumberFormat = "0.00"
                    Selection.HorizontalAlignment = xlCenter
        
                    'clear spaces out of "order quantity" column
                    Cells(brow, 7) = ""
                    
                    'format "order quantity" column and unprotect cell
                    Cells(brow, 7).Select
                    With Selection.Borders
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    
                    With Selection.Validation
                        .Delete
                        .Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, _
                        Operator:=xlBetween, Formula1:="0", Formula2:="999999999999999999999"
                        .InputMessage = "Enter Positive Whole Numbers Only"
                        .ErrorTitle = "Whole Numbers Only"
                        .ErrorMessage = "Only Enter Positive Whole Numbers." & vbCrLf & vbCrLf & _
                        "Please put additional information in the ""Cust. Notes"" column."
                        .ShowInput = True
                        .ShowError = True
                    End With
                    
                    With Selection
                        .NumberFormat = "0"
                        .HorizontalAlignment = xlCenter
                        .Locked = False
                        .FormulaHidden = False
                        .Font.Bold = True
                    End With
                    
                    'insert formula in "total" column
                    Cells(brow, 8) = "=F" & brow & "*G" & brow
                    Cells(brow, 8).Select
                    Selection.NumberFormat = "0.00"
                    Selection.HorizontalAlignment = xlCenter
                    
                    'format "customer note" column and unprotect cell
                    Cells(brow, 11).Select
                    With Selection.Borders
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    
                    With Selection
                        .HorizontalAlignment = xlLeft
                        .Locked = False
                        .FormulaHidden = False
                    End With
                    
            End Select
        
            brow = brow + 1
            
        Loop Until brow = arow
    
        'add totals below EOF
        Cells(arow + 1, 7) = "Total ="
        Cells(arow + 1, 8) = "=sum(h8:h" & arow - 1 & ")"
        Range(Cells(arow + 1, 7), Cells(arow + 1, 8)).Select
        With Selection
            .Font.Bold = True
            .NumberFormat = "0.00"
        End With
        
        With Selection.Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        
        'loop to delete rows marked for deletion and autofit rows not to be deleted
        brow = 8
        bcol = 2
        
        Do
            Cells(brow, bcol).Select
            If ActiveCell = "Delete" Then
                Rows(brow).Select
                Selection.Delete Shift:=xlUp
                brow = brow - 1
            Else
                Range(Cells(brow, 1), Cells(brow, 12)).Select
                Selection.Rows.AutoFit
            End If
            
            brow = brow + 1
        
        Loop Until brow = arow
    
    '************************************************************************************************
    '*                                                                                              *
    '*CGE00:                FORMAT PAGE FOR PRINTING                                                *
    '*                                                                                              *
    '************************************************************************************************
    
        'hide item key
        Columns("A:A").EntireColumn.Hidden = True
        
        'set column widths and text wrap
        Cells.VerticalAlignment = xlTop
        Columns("C:C").ColumnWidth = 13.14
        Columns("C:C").WrapText = True
        Columns("D:D").ColumnWidth = 18.86
        Columns("D:D").WrapText = True
        Columns("E:E").ColumnWidth = 5.57
        Columns("E:E").WrapText = True
        Columns("F:F").ColumnWidth = 7.57
        Columns("G:G").ColumnWidth = 8.29
        Columns("H:H").ColumnWidth = 10.71
        Columns("I:I").ColumnWidth = 11
        Columns("I:I").WrapText = True
        Columns("J:J").ColumnWidth = 11.43
        Columns("J:J").WrapText = True
        Columns("K:K").ColumnWidth = 14.57
        Columns("L:L").ColumnWidth = 31.71
        Columns("L:L").WrapText = True
        Columns("N:N").ColumnWidth = 7.71
        Columns("N:N").WrapText = True
    
        'page setup for print
        With ActiveSheet.PageSetup
            .PrintTitleRows = "$1:$7"
            .PrintTitleColumns = ""
            .PrintArea = ""
            .Orientation = xlPortrait
            .RightFooter = "Page &P of &N"
            .RightHeader = "Page:_____of_____"
            .LeftMargin = Application.InchesToPoints(0.2)
            .RightMargin = Application.InchesToPoints(0.2)
            .TopMargin = Application.InchesToPoints(0.3)
            .BottomMargin = Application.InchesToPoints(0.3)
            .HeaderMargin = Application.InchesToPoints(0.15)
            .FooterMargin = Application.InchesToPoints(0.15)
            .PrintComments = xlPrintNoComments
            .PrintQuality = 600
            .PaperSize = xlPaperLetter
            .CenterHorizontally = True
            .Zoom = 69
        End With
        
        'freeze panes
        Application.ScreenUpdating = True
        Cells(8, 2).Select
        ActiveWindow.FreezePanes = True
        Application.ScreenUpdating = False
        
        'protect sheet
        Call protect_avail
    
        'create template and sold out list
        Call avail_template_and_sold_out_list
      
        If test = False Then
            MsgBox ("Complete, Sheet Protected")
            Else
            MsgBox ("Complete, TEST Sheet NOT Protected")
        End If
        
    End Sub


    • Edited by jmilliken Wednesday, July 29, 2015 9:16 PM i suck at grammar
    Wednesday, July 29, 2015 9:11 PM

All replies

  • Hi jmilliken,

    I would like to know the details below:

    1. What’s the result if you just add the validation by using your code (With Selection.Validation…)?
    2. What’s the version of your Excel
    3. Could you reproduce that issue in another file? If so, please share the sample file on the OneDrive.
    4. You said that the data validation MsgBox will display if the file is not open, how do you did it, please provide the detail steps.

    Regards

    Starain


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Friday, July 31, 2015 1:36 AM
    Moderator