how to make program simpler

[Lorenzo Kim]

I wrote the following program lines (very crude) - but it is working quite well!

what it does is checking the cell above - if blank, it will not allow data entry - meaning data should be entered in sequence - no leaving of blanks on top. 

there is a pattern here and I know there is a better way of writing this.

a very much simpler code..

number array in use = 4,5,8,11,14,15,16,19,20,21,24,27,30

the hi-lighted in BOLD is the one that is repetitive with respect to the above array

HELP WILL BE VERY MUCH APPRECIATED

The code inside worksheet_change:

Dim ErrEntry As Boolean
ErrEntry = False

If ([B4] > 0 And ([B3] = 0 Or [C3] = 0)) Or ([C4] > 0 And ([B3] = 0 Or [C3] = 0)) Then
    If [B4] > 0 Then
        Sheet20.Range("B4").Select
    Else
        Sheet20.Range("C4").Select
    End If
    ErrEntry = True
End If
If ([B5] > 0 And ([B4] = 0 Or [C4] = 0)) Or ([C5] > 0 And ([B4] = 0 Or [C4] = 0)) Then
    If [B5] > 0 Then
        Sheet20.Range("B5").Select
    Else
        Sheet20.Range("C5").Select
    End If
    ErrEntry = True
End If
If ([B8] > 0 And ([B7] = 0 Or [C7] = 0)) Or ([C8] > 0 And ([B7] = 0 Or [C7] = 0)) Then
    If [B8] > 0 Then
        Sheet20.Range("B8").Select
    Else
        Sheet20.Range("C8").Select
    End If
    ErrEntry = True
End If
If ([B11] > 0 And ([B10] = 0 Or [C10] = 0)) Or ([C11] > 0 And ([B10] = 0 Or [C10] = 0)) Then
    If [B11] > 0 Then
        Sheet20.Range("B11").Select
    Else
        Sheet20.Range("C11").Select
    End If
    ErrEntry = True
End If
If ([B14] > 0 And ([B13] = 0 Or [C13] = 0)) Or ([C14] > 0 And ([B13] = 0 Or [C13] = 0)) Then
    If [B14] > 0 Then
        Sheet20.Range("B14").Select
    Else
        Sheet20.Range("C14").Select
    End If
    ErrEntry = True
End If
If ([B15] > 0 And ([B14] = 0 Or [C14] = 0)) Or ([C15] > 0 And ([B14] = 0 Or [C14] = 0)) Then
    If [B15] > 0 Then
        Sheet20.Range("B15").Select
    Else
        Sheet20.Range("C15").Select
    End If
    ErrEntry = True
End If
If ([B16] > 0 And ([B15] = 0 Or [C15] = 0)) Or ([C16] > 0 And ([B15] = 0 Or [C15] = 0)) Then
    If [B16] > 0 Then
        Sheet20.Range("B16").Select
    Else
        Sheet20.Range("C16").Select
    End If
    ErrEntry = True
End If
If ([B19] > 0 And ([B18] = 0 Or [C18] = 0)) Or ([C19] > 0 And ([B18] = 0 Or [C18] = 0)) Then
    If [B19] > 0 Then
        Sheet20.Range("B19").Select
    Else
        Sheet20.Range("C19").Select
    End If
    ErrEntry = True
End If
If ([B20] > 0 And ([B19] = 0 Or [C19] = 0)) Or ([C20] > 0 And ([B19] = 0 Or [C19] = 0)) Then
    If [B20] > 0 Then
        Sheet20.Range("B20").Select
    Else
        Sheet20.Range("C20").Select
    End If
    ErrEntry = True
End If
If ([B21] > 0 And ([B20] = 0 Or [C20] = 0)) Or ([C21] > 0 And ([B20] = 0 Or [C20] = 0)) Then
    If [B21] > 0 Then
        Sheet20.Range("B21").Select
    Else
        Sheet20.Range("C21").Select
    End If
    ErrEntry = True
End If
If ([B24] > 0 And ([B23] = 0 Or [C23] = 0)) Or ([C24] > 0 And ([B23] = 0 Or [C23] = 0)) Then
    If [B24] > 0 Then
        Sheet20.Range("B24").Select
    Else
        Sheet20.Range("C24").Select
    End If
    ErrEntry = True
End If
If ([B27] > 0 And ([B26] = 0 Or [C26] = 0)) Or ([C27] > 0 And ([B26] = 0 Or [C26] = 0)) Then
    If [B27] > 0 Then
        Sheet20.Range("B27").Select
    Else
        Sheet20.Range("C27").Select
    End If
    ErrEntry = True
End If
If ([B30] > 0 And ([B29] = 0 Or [C29] = 0)) Or ([C30] > 0 And ([B29] = 0 Or [C29] = 0)) Then
    If [B30] > 0 Then
        Sheet20.Range("B30").Select
    Else
        Sheet20.Range("C30").Select
    End If
    ErrEntry = True
End If

If ErrEntry Then
    MsgBox "ABOVE CELL HAS NO/INCOMPLETE INPUT! Data entry not allowed.."
    Selection.ClearContents
    Exit Sub
End If

[#2 · Accepted solution]

Hi Lorenzo,

I think this should do it:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    'Only if in right cells:
    Const CSApplicableRows As String = ",4,5,8,11,14,15,16,19,20,21,24,27,30,"    'Please start and end with a comma!!
    Dim oCells2Check As Range
    'Only if one cell was changed
    If Target.Cells.Count > 1 Then Exit Sub
    'Only if cell is in col B or C
    If Intersect(Target, Range("B:C")) Is Nothing Then Exit Sub
    'Only in desginated rows
    If InStr(CSApplicableRows, "," & Target.Row & ",") = 0 Then Exit Sub
    Set oCells2Check = Intersect(Range("B:C"), Target.EntireRow)
    
    If (oCells2Check.Cells(1, 1) > 0 And (oCells2Check.Cells(1, 1).Offset(-1, 0) = 0 Or oCells2Check.Cells(1, 2).Offset(-1, 0) = 0)) _
    Or (oCells2Check.Cells(1, 2) > 0 And (oCells2Check.Cells(1, 1).Offset(-1, 0) = 0 Or oCells2Check.Cells(1, 2).Offset(-1, 0) = 0)) Then

   ' If ([B4] > 0 And ([B3] = 0 Or [C3] = 0)) Or ([C4] > 0 And ([B3] = 0 Or [C3] = 0)) Then
        If oCells2Check.Cells(1, 1) > 0 Then
            oCells2Check.Cells(1, 1).Select
        Else
            oCells2Check.Cells(1, 2).Select
        End If
        MsgBox "ABOVE CELL HAS NO/INCOMPLETE INPUT! Data entry not allowed.."
        Selection.ClearContents
        Exit Sub
    End If
End Sub

[#3]

Mr Pieterse

Thank you very much for your reply.

it worked almost perfectly except for this scenario: 

in the image below - if we delete  B3  (600) or C3 (1)  [both B3 & C3 should be filled up to constitute a complete data]  , B4 & C4 should be deleted- following the rule that no entry can be allowed if above cell is blank or incomplete.  in which case B5 & C5 should also be deleted.

same rule would also apply to the other groups (each pink colored boxes forms a group based on components name)

(Should'nt the MsgBox be outside of the loop?)

[#4]

The msgbox is not in any loop as far as I can tell. Note that my sample only checks the entries when a cell in C or D is modified which is on one of the rows as indicated, it does not check all cells.

[#5]

Mr Pieterse

Thank you very very much