none
Values are not Pasting RRS feed

  • Question

  • Hi

    I would like to know that I have a Excel Macro Enabled File.

    it has macros, sheet vba code, modules and user forms code and no merging cells

    but problem is that whenever or whatever I'm trying to paste any values, it's not pasting the values

    just shows once action that pasted and in a second it automatically removes the values not only from the file but also from the memory.

    Please help me to solve this unique problem

    Thanks



    • Edited by SMuneebH Thursday, December 3, 2015 8:58 AM
    Thursday, December 3, 2015 8:23 AM

Answers

  • Your problem is that you have

    On Error Resume Next

    and this code fails

    If rngTarg.Offset(0, 2) = "Repeater(s)" Or rngTarg.Offset(0, 2) = "Improvement" Then

    and then it just continues on until it gets to:

    rngTarg.ClearContents

    So, you need to either loop through the rngTarg cells, or just use the first cell - where would Repeater(s) or Improvement be located? If it for each cell in the Range, then use code like

    Dim C As Range 'Put at the top of your module

    For Each C In rngTarg

    If C.Offset(0, 2) = "Repeater(s)" Or C.Offset(0, 2) = "Improvement" Then MsgBox "As you enter <" & C.Offset(0, 2) & "> in Student's Name Column in <" & SheetName & ">" _ & vbNewLine & "that is why you cannot enter Seat No.", vbInformation, "Information" C.ClearContents End If

    Next C

    Or, instead of looping, you could write your code that it only fires when the values are changing for a single cell instead of multiple cells:

    Private Sub Worksheet_Change(ByVal Target As Range)

        If Target.Cells.Count > 1 Then Exit Sub

       Select Case True

    ..... rest of code

    Or you can better explain what it is that you are doing, or share a workbook that has the structure required for the code to work.


    Friday, December 4, 2015 5:05 PM

All replies

  • Sounds like you have some event code that may be present, and is working to prevent pasting. What is the 'sheet vba code' that you have?
    Friday, December 4, 2015 2:26 PM
  • Hi

    Thanks for response

    My sheet has a very long code

    ' ALLAH help me to make this Flawless Project
    Private Sub Worksheet_Change(ByVal Target As Range)
        Select Case True
    ' Next line Not Nothing then is something so Target is within the range
    ' this code refers to Column B
            Case Not Intersect(Target, Me.Range("B11:B510")) Is Nothing
                Call ChangeColB(Target)
    ' this code refers to Column C
            Case Not Intersect(Target, Me.Range("C11:C510")) Is Nothing
                Call ChangeColC(Target)
    ' this code refers to Column D
            Case Not Intersect(Target, Me.Range("D11:D510")) Is Nothing
                Call ChangeColD(Target)
    ' this code refers to Column E
            Case Not Intersect(Target, Me.Range("E11:E510")) Is Nothing
                Call ChangeColE(Target)
    ' this code refers to Column F
            Case Not Intersect(Target, Me.Range("F11:F510")) Is Nothing
                Call ChangeColF(Target)
        End Select
    End Sub
    
    'the below code refers to Column B
    
    Sub ChangeColB(rngTarg As Range)
        'Application.ScreenUpdating = False
        On Error Resume Next
        Application.EnableEvents = False
        'Application.DisplayAlerts = False
    
        Dim rng As Range
        Dim n As Integer
        Dim cEdit As Integer
        Dim SheetName As String
        Dim WorkbookName As String
        
        Set rngCheck = Range("D11:D510")
        Set rngBlock = Range("B11:B510")
        
        SheetName = ActiveSheet.Name
        WorkbookName = ActiveWorkbook.Name
    
        If Intersect(rngTarg, rngBlock) Is Nothing Then
            GoTo ReEnableEvent ' Do nothing or what you want
        Else
        'It will help to remove data if user enter seat no as student columns contains "Repeater(s)" Or "Improvement"
            If rngTarg.Offset(0, 2) = "Repeater(s)" Or rngTarg.Offset(0, 2) = "Improvement" Then
                rngTarg.Select
                MsgBox "As you enter <" & rngTarg.Offset(0, 2) & "> in Student's Name Column in <" & SheetName & ">" _
                & vbNewLine & "that is why you cannot enter Seat No.", vbInformation, "Information"
                rngTarg.ClearContents
            End If
         End If
        Application.EnableEvents = True
        
        If Not Intersect(rngTarg, rng) Is Nothing And rngTarg.Count = 1 Then
            If rngTarg.Value = "" Then Exit Sub
        Application.EnableEvents = False
            If Len(rngTarg.Value) > 12 Then GoTo Errhandler
    '1
        n = 3
        If UCase(Left(rngTarg.Value, n)) Like "[A-Z][A-Z]-" Then
            If Len(rngTarg.Value) > n And Len(rngTarg.Value) <= n + 9 Then
            For X = n + 1 To Len(rngTarg.Value)
            If Not Mid(rngTarg.Value, X, 1) Like "[0-9]" Then GoTo Errhandler 'fg = True: GoTo ErrHandler
        Next
            rngTarg.Value = UCase(rngTarg.Value)
        GoTo ReEnableEvent
            End If
        End If
    '2
        n = 2
        If UCase(Left(rngTarg.Value, n)) Like "[A-Z]-" Then
            If Len(rngTarg.Value) > n And Len(rngTarg.Value) <= n + 9 Then
            For X = n + 1 To Len(rngTarg.Value)
            If Not Mid(rngTarg.Value, X, 1) Like "[0-9]" Then GoTo Errhandler 'fg = True: GoTo ErrHandler
        Next
            rngTarg.Value = UCase(rngTarg.Value)
        GoTo ReEnableEvent
            End If
        End If
    '3
        n = 2
        If UCase(Left(rngTarg.Value, n)) Like "[A-Z][A-Z]" Then
            If Len(rngTarg.Value) > n And Len(rngTarg.Value) <= n + 9 Then
            For X = n + 1 To Len(rngTarg.Value)
            If Not Mid(rngTarg.Value, X, 1) Like "[0-9]" Then GoTo Errhandler 'fg = True: GoTo ErrHandler
        Next
            rngTarg.Value = Left(rngTarg.Value, n) & "-" & Right(rngTarg.Value, Len(rngTarg.Value) - n)
            rngTarg.Value = UCase(rngTarg.Value)
        GoTo ReEnableEvent
            End If
        End If
    '4
        n = 1
        If UCase(Left(rngTarg.Value, n)) Like "[A-Z]" Then
            If Len(rngTarg.Value) > n And Len(rngTarg.Value) <= n + 9 Then
            For X = n + 1 To Len(rngTarg.Value)
            If Not Mid(rngTarg.Value, X, 1) Like "[0-9]" Then GoTo Errhandler 'fg = True: GoTo ErrHandler
        Next
            rngTarg.Value = Left(rngTarg.Value, n) & "-" & Right(rngTarg.Value, Len(rngTarg.Value) - n)
            rngTarg.Value = UCase(rngTarg.Value)
        GoTo ReEnableEvent
            End If
        End If
       
    Errhandler:
        rngTarg.Select
            cEdit = MsgBox("You entered <" & rngTarg & "> is Invalid in <" & SheetName & ">" _
                & vbNewLine & "Re-enter the Seat No. in one of the following description" _
                & vbNewLine & "1. First any 1 Single Alpha Character" _
                & vbNewLine & "    and rest of Numeric Characters not Exceed to 9 Digits OR" _
                & vbNewLine & "2. First any 2 Double Alpha Characters" _
                & vbNewLine & "    and rest of Numeric Characters not Exceed to 9 Digits" _
                & vbNewLine & "    as provided by Semester Section." _
                & vbNewLine & "3. Hypen may be omitted during entry." _
                & vbNewLine & "Click Ok for Remove Seat No OR" _
                & vbNewLine & "Click Cancel for Correction", vbCritical + vbOKCancel + vbDefaultButton2, "Invalid Entry!")
                If cEdit = vbOK Then
                    rngTarg.ClearContents
                End If
                If cEdit = vbCancel Then
                    rngTarg.Select
                    Application.SendKeys "{F2}"
                End If
    
    ReEnableEvent:
         ' New Code for Duplication Entry starts here
         If WorksheetFunction.CountIf(Me.Range("B11:B510"), rngTarg.Value) > 1 Then
            rngTarg.Select
            cEdit = MsgBox("You have enter the Seat No." _
                & vbNewLine & "<" & rngTarg.Value & "> is already exist in <" & SheetName & ">." _
                & vbNewLine & "Click Ok to Remove Seat No OR" _
                & vbNewLine & "Click Cancel for Correction", vbExclamation + vbOKCancel + vbDefaultButton2, "Duplicate Entry!")
            If cEdit = vbOK Then
                rngTarg.ClearContents
            End If
            If cEdit = vbCancel Then
                rngTarg.Select
                Application.SendKeys "{F2}"
            End If
    
         End If
         ' New Code for Duplication Entry ends here
    
        Application.EnableEvents = True
        'Application.ScreenUpdating = True
        
    End If
    Application.EnableEvents = True
    End Sub
    
    'the below code refers to Column C
    
    Sub ChangeColC(rngTarg As Range)
         'Application.ScreenUpdating = False
         On Error GoTo ReEnableEvents
         Application.EnableEvents = False
         'Application.DisplayAlerts = False
         
         Dim regExp As Object
         Dim strTarg As String
         Dim cEdit As Integer
         Dim i As Long
         Dim strPattern As String
         Dim arrTarg(1 To 4) As String
         Dim lngMidChrs As Long
         Dim ShtName As String
         Dim WrkbookName As String
    
         ShtName = ActiveSheet.Name
         WrkbookName = ActiveWorkbook.Name
         
         Set rngCheck = Range("D11:D510")
         Set rngBlock = Range("C11:C510")
        
          ' New Code for Empty Previous Cell of same Row (Seat No) starts here
         If Not Intersect(rngTarg, Me.Range("C11:C510")) Is Nothing Then
            If rngTarg.Value = "" Then GoTo ReEnableEvents
         If (IsEmpty(rngTarg.Offset(0, -1))) Then
            rngTarg.Select
            MsgBox "First enter Seat No. in <" & ShtName & ">", vbInformation + vbOKOnly, "Entry Required"
            rngTarg.ClearContents
            GoTo ReEnableEvents
            End If
         End If
         ' New Code for Empty Previous Cell of same Row (Seat No)ends here
        
        'Test if user entered "Applied For" in lieu of Enrol No. code.
        'Test in upper case and if correct characters then convert to Proper case"
         If UCase(Trim(rngTarg.Value)) = "APPLIED FOR" Then
             rngTarg.Value = WorksheetFunction.Proper(Trim(rngTarg.Value))
             GoTo ReEnableEvents    'Finished processing because "Applied for" entered
         End If
        
        Set regExp = CreateObject("VBScript.RegExp")
    
            'Following line represents: '1st element plus Slash after 1st element
                                        '2nd element plus Slash after 2nd element
                                        '3rd element plus Slash after 3rd element
                                        '4th element
                                        
         'Convert alpha characters to upper case and remove spaces and slashes (if any)
         strTarg = UCase(Replace((Replace(rngTarg.Value, " ", "")), "/", ""))
         strPattern = "^[A-Z]{6,7}[0-9]{8}$"     'Pattern to match
        
         If IsAMatch(regExp, strPattern, strTarg) Then
             'Insert the slashes in that pattern with 3 alphas in the second block
             If Len(strTarg) = 14 Then       'If 3 alpha + 3 alpha + 4 numeric + 4 numeric
                 rngTarg.Value = Left(strTarg, 3) & "/" & Mid(strTarg, 4, 3) & "/" & Chr(10) _
                                                    & Mid(strTarg, 7, 4) & "/" & Mid(strTarg, 11, 4)
             Else            'If 3 alpha + 4 alpha + 4 numeric + 4 numeric
                 'insert the slashes in the pattern with 4 alphas in the second block
                 rngTarg.Value = Left(strTarg, 3) & "/" & Mid(strTarg, 4, 4) & "/" & Chr(10) _
                                                    & Mid(strTarg, 8, 4) & "/" & Mid(strTarg, 12, 4)
                GoTo ReEnableEvents
             End If
         
        'It will help to remove data if user enter enrolment no as student columns contains "Repeater(s)" Or "Improvement"
        If Intersect(rngTarg, rngBlock) Is Nothing Then
            GoTo ReEnableEvents ' Do nothing or what you want
        Else
            If rngTarg.Offset(0, 1) = "Repeater(s)" Or rngTarg.Offset(0, 1) = "Improvement" Then
                rngTarg.Select
                MsgBox "As you enter <" & rngTarg.Offset(0, 1) & "> in Student's Name Column in <" & ShtName & ">" _
                & vbNewLine & "that is why you cannot enter Enrolment No.", vbInformation, "Information"
                rngTarg.ClearContents
            End If
         End If
         Application.EnableEvents = True
    'ErrHandler:
         Else
             rngTarg.Select
             cEdit = MsgBox("You entered <" & rngTarg & "> is Invalid in <" & ShtName & ">" _
                 & vbNewLine & "Re-enter the Enrolment No. in one of the following description" _
                 & vbNewLine & "1. Write only -> applied for <- OR" _
                 & vbNewLine & "2. First write any 6 Alpha Characters and" _
                 & vbNewLine & "    Second write any 8 Numeric Charaters OR" _
                 & vbNewLine & "3. First write any 7 Alpha Characters and" _
                 & vbNewLine & "    Second write any 8 Numeric Charaters" _
                 & vbNewLine & "    as provided by Enrolment Section." _
                 & vbNewLine & "4. Slashes may be omitted during entry." _
                 & vbNewLine & "Click Ok for Remove Enrolment no OR" _
                 & vbNewLine & "Click Cancel for Correction", vbCritical + vbOKCancel + vbDefaultButton2, "Invalid Entry!")
            If cEdit = vbOK Then
                rngTarg.ClearContents
            End If
            If cEdit = vbCancel Then
                rngTarg.Select
                Application.SendKeys "{F2}"
            End If
    
    ReEnableEvents:
         
         ' New Code for Duplication Entry starts here
         If WorksheetFunction.CountIf(Me.Range("C11:C510"), rngTarg.Value) > 1 And rngTarg.Value <> "Applied For" Then
            rngTarg.Select
            cEdit = MsgBox("You have enter the Enrolment No. <" & rngTarg.Value & "> in <" & ShtName & ">" _
                & vbNewLine & "is already exist. Click Ok to remove OR" _
                & vbNewLine & "Click Cancel for Correction", vbExclamation + vbOKCancel + vbDefaultButton2, "Duplicate Entry!")
            If cEdit = vbOK Then
                rngTarg.ClearContents
            End If
            If cEdit = vbCancel Then
                rngTarg.Select
                Application.SendKeys "{F2}"
            End If
    
         End If
         ' New Code for Duplication Entry ends here
         
         If Err.Number <> 0 Then
                 MsgBox "Error occurred in Private Sub Worksheet_Change." _
                    & vbNewLine & "Refer to Administrator Muneeb (KUBS - University of Karachi)" _
                    & vbNewLine & "of this workbook.", vbCritical, "Error!"
         End If
         Application.EnableEvents = True
         'Application.ScreenUpdating = True
         End If
     Application.EnableEvents = True
    End Sub
    
    'the below code refers to Column D
    
    Sub ChangeColD(rngTarg As Range)
        Dim i As Long
        Dim j As Long
        Dim cEdit As Integer
        Dim SoDoTarg() As String
        Dim strTarg() As String, bFound As Boolean
        Dim rngToChk As Range
        Dim cAccept As Integer
        Dim SheetName As String
        Dim WorkbookName As String
    
        SheetName = ActiveSheet.Name
        WorkbookName = ActiveWorkbook.Name
        
        bFound = False
        
         'Application.ScreenUpdating = False
         On Error GoTo DupName
         Application.EnableEvents = False
         'Application.DisplayAlerts = False
         
        ' New Code for Empty Previous Cell of same Row (Enrolment No) starts here
         If Not Intersect(rngTarg, Me.Range("D11:D510")) Is Nothing Then
            If rngTarg.Value = "" Then GoTo DupName
            If rngTarg.Value = "repeat" Or rngTarg.Value = "improve" Then GoTo Excp
         If (IsEmpty(rngTarg.Offset(0, -1))) Then
            rngTarg.Select
            MsgBox "First enter Enrolment No. in <" & SheetName & ">", vbInformation + vbOKOnly, "Entry Required"
            rngTarg.ClearContents
            End If
         End If
         ' New Code for Empty Previous Cell of same Row (Enrolment No) ends here
        
        SoDoTarg = Split("s/o, S/O, s /o, S /O, s / o, S / O, s/ o, S/ O, S / o, s/ O, S/ o, s/O, S/o, s /O, S /o, s / O, S / o, d/o, D/O, d /o, D /O, d / o, D / O, d/ o, D/ O, D / o, d/ O, D/ o, d/O, D/o, d /O, D /o, d / O, D / o", ", ")
          For i = 1 To UBound(SoDoTarg) + 1
            If InStr(1, WorksheetFunction.Trim(rngTarg), SoDoTarg(i - 1)) Then
                rngTarg = Replace(WorksheetFunction.Trim(rngTarg), SoDoTarg(i - 1), "/", 1)
                Exit For
            End If
         Next i
    Excp:
         strTarg = Split(rngTarg.Value, "/")
         For j = 0 To UBound(strTarg)
           strTarg(j) = Trim(strTarg(j))
           If Left(LCase(strTarg(j)), 6) = "repeat" Then
              strTarg(j) = "Repeater(s)"
              bFound = True
          End If
          If Left(LCase(strTarg(j)), 7) = "improve" Then
              strTarg(j) = "Improvement"
              bFound = True
          End If
         Next j
         
         If Application.CountA(strTarg) > 1 Or bFound Then
          If Application.CountA(strTarg) > 1 Then
             rngTarg.Value = StrConv(Trim(strTarg(0)) & " / " & Chr(10) & Trim(strTarg(1)), vbProperCase)
             rngTarg.Value = Application.WorksheetFunction.Substitute(rngTarg.Value, Chr(10), Chr(191), 1)
             rngTarg.Value = VBA.Replace(rngTarg.Value, Chr(10), vbNullString)
             rngTarg.Value = Application.WorksheetFunction.Substitute(rngTarg.Value, Chr(191), Chr(10), 1)
             GoTo DupName
          ElseIf bFound Then
           rngTarg.Value = strTarg(0)
          End If
        End If
        
    ' this code is for desing clear data if seat no or / and enrolment no enter before Repeater(s) or Improvement
    ' this code is adjusted by Muneeb with the help of Microsoft Community Member
      If rngTarg Is Nothing Then Exit Sub
      Application.EnableEvents = False
      For Each rngToChk In rngTarg
        Select Case rngToChk.Value
          Case "Repeater(s)", "Improvement"
          'rngTarg.Select
          'cAccept = MsgBox("This will clear the data if you have entered in Seat No. or Enrol No or Internal Marks" _
          '& vbNewLine & "For Continue click Ok or For Correction click Cancel.", vbOKCancel + vbInformation, "Removal")
          'If cAccept = vbOK Then
            rngToChk.Offset(0, -1).ClearContents
            rngToChk.Offset(0, -2).ClearContents
            rngToChk.Offset(0, 1).ClearContents
            rngToChk.Offset(0, 2).ClearContents
          'End If
          'If cAccept = vbCancel Then
          'Exit Sub
          'End If
          End Select
    Next
    ' this code is adjusted by Muneeb with the help of Microsoft Community Member
    IncName:
        If rngTarg.Value = "Repeater(s)" Or rngTarg.Value = "Improvement" Then
            GoTo DupName
        Else
        rngTarg.Select
            cEdit = MsgBox("Not only Student's Name <" & rngTarg & "> in <" & SheetName & ">" _
            & vbNewLine & "Father's name is also be written." _
            & vbNewLine & "Click Ok for Remove Student's Name OR" _
            & vbNewLine & "Click Cancel for Enter Father's Name", vbInformation + vbOKCancel + vbDefaultButton2, "Missing!")
        If cEdit = vbOK Then
            rngTarg.ClearContents
        End If
        If cEdit = vbCancel Then
            rngTarg.Select
            Application.SendKeys "{F2}"
        End If
    
    
    DupName:
        ' New Code for Duplication Entry starts here
        If WorksheetFunction.CountIf(Me.Range("D11:D510"), rngTarg.Value) > 1 Then
           rngTarg.Select
           cEdit = MsgBox("You have enter the Student's Name <" & rngTarg.Value & "> in <" & SheetName & ">" _
                    & vbNewLine & "is already exist." _
                    & vbNewLine & "Click Ok for Reomve Student's Name OR" _
                    & vbNewLine & "Click Cancel for Correction", vbInformation + vbOKCancel + vbDefaultButton2, "Duplicate Entry!")
           If cEdit = vbOK Then
               rngTarg.ClearContents
           End If
           If cEdit = vbCancel Then
                rngTarg.Select
                Application.SendKeys "{F2}"
           End If
    
        End If
        ' New Code for Duplication Entry ends here
        
         Application.EnableEvents = True
         'Application.ScreenUpdating = True
     End If
     Application.EnableEvents = True
     End Sub
     
     'the below code refers to Column E
     
    Sub ChangeColE(rngTarg As Range)
        Set rngCheck = Range("D11:D510")
        Set rngBlock = Range("E11:E510")
        
        Dim rng As Range, Cell As Range
        Dim SheetName As String
        Dim WorkbookName As String
    
        SheetName = ActiveSheet.Name
        WorkbookName = ActiveWorkbook.Name
        
        Application.EnableEvents = False
        
        ' New Code for Empty Previous Cell of same Row (Internal Marks) starts here
        If Not Intersect(rngTarg, Me.Range("E11:E510")) Is Nothing Then
            If rngTarg.Value = "" Then Application.EnableEvents = True
        If (IsEmpty(rngTarg.Offset(0, -1))) Then
            rngTarg.Select
            MsgBox "First enter Student's Name in <" & SheetName & ">", vbInformation + vbOKOnly, "Entry Required"
            rngTarg.ClearContents
            Application.EnableEvents = True
            End If
        End If
        ' New Code for Empty Previous Cell of same Row (Internal Marks) ends here
         
        For Each Cell In rngTarg
        'It will help to converted a single alphabet to change in UPPER CASE
            If Len(Cell) = 1 Then
                Cell.Value = UCase(Cell.Value)
            End If
        'It will help to convert "Zero" in Proper Case which is added by Muneeb
            If Len(Cell) > 1 Then
                Cell.Value = WorksheetFunction.Proper(Cell.Value)
            End If
    
        If Intersect(rngTarg, rngBlock) Is Nothing Then
            Application.EnableEvents = True ' Do nothing or what you want
        Else
        'It will help to remove data if user enter internal marks as student columns contains "Repeater(s)" Or "Improvement"
            If rngTarg.Offset(0, -1) = "Repeater(s)" Or rngTarg.Offset(0, -1) = "Improvement" Then
                rngTarg.Select
                MsgBox "As you enter <" & rngTarg.Offset(0, -1) & "> in Student's Name Column in <" & SheetName & ">" _
                & vbNewLine & "that is why you cannot enter Internal Marks", vbInformation, "Information"
                Application.EnableEvents = False
                rngTarg.ClearContents
            End If
        End If
    Next
        Application.EnableEvents = True
    
    End Sub
    
    'the below code refers to Column F
    
    Sub ChangeColF(rngTarg As Range)
        Set rngCheck = Range("D11:D510")
        Set rngBlock = Range("F11:F510")
        
        Dim rng As Range, cel As Range
        Dim SheetName As String
        Dim WorkbookName As String
    
        SheetName = ActiveSheet.Name
        WorkbookName = ActiveWorkbook.Name
        
        Application.EnableEvents = False
        
        ' New Code for Empty Previous Cell of same Row (External Marks) starts here
        If Not Intersect(rngTarg, Me.Range("F11:F510")) Is Nothing Then
            If rngTarg.Value = "" Then Application.EnableEvents = True
        If (IsEmpty(rngTarg.Offset(0, -2))) Then
            rngTarg.Select
            MsgBox "First enter Student's Name in <" & SheetName & ">", vbInformation + vbOKOnly, "Entry Required"
            rngTarg.ClearContents
            Application.EnableEvents = True
            End If
        End If
        ' New Code for Empty Previous Cell of same Row (External Marks) ends here
        
        For Each cel In rngTarg
    'It will help to converted a single alphabet to change in UPPER CASE
            If Len(cel) = 1 Then
                cel.Value = UCase(cel.Value)
            End If
    'It will help to convert "Zero" in Proper Case which is added by Muneeb
            If Len(cel) > 1 Then
                cel.Value = WorksheetFunction.Proper(cel.Value)
            End If
       'Skip text
            If IsNumeric(cel.Value) And cel.Value <> "" Then
       'Change if match
            If cel.Value > 24 And cel.Value < 30 Then
                cel.Value = 30
            End If
            End If
                    
            If Intersect(rngTarg, rngBlock) Is Nothing Then
            Application.EnableEvents = True ' Do nothing or what you want
        Else
            'It will help to remove data if user enter external marks as student columns contains "Repeater(s)" Or "Improvement"
            If rngTarg.Offset(0, -2) = "Repeater(s)" Or rngTarg.Offset(0, -2) = "Improvement" Then
                rngTarg.Select
                MsgBox "As you enter <" & rngTarg.Offset(0, -2) & "> in Student's Name Column in <" & SheetName & ">" _
                & vbNewLine & "that is why you cannot enter External Marks", vbInformation, "Information"
                Application.EnableEvents = False
                rngTarg.ClearContents
            End If
        End If
        Next cel
            Application.EnableEvents = True
    End Sub
    
    'the below code refers to Column C
    
    Function IsAMatch(regEx As Object, strPatt As String, strToTest As String) As Boolean
        'On Error GoTo ReEnableEvents
         Dim regMatch As Object  ' MatchCollection
    
         With regEx
           .Pattern = strPatt
           .MultiLine = False
           .IgnoreCase = False     'Do NOT IgnoreCase. Set to True to Ignore Case
         End With
    
         'Match test string against regEx pattern string
         Set regMatch = regEx.Execute(strToTest)
         IsAMatch = (regMatch.Count > 0)
    
         Exit Function   'Do not re-enable events here unless error sends code to Sub routine
    
    ReEnableEvents:
        If Err.Number <> 0 Then
            MsgBox "Error occurred in Function IsAMatch." _
                 & vbNewLine & "Refer to Administrator Muneeb (KUBS - University of Karachi)" _
                 & vbNewLine & "of this workbook.", vbCritical, "Error!"
        End If
        Application.EnableEvents = True
    End Function
    
    
    
    

    Friday, December 4, 2015 3:43 PM
  • Your problem is that you have

    On Error Resume Next

    and this code fails

    If rngTarg.Offset(0, 2) = "Repeater(s)" Or rngTarg.Offset(0, 2) = "Improvement" Then

    and then it just continues on until it gets to:

    rngTarg.ClearContents

    So, you need to either loop through the rngTarg cells, or just use the first cell - where would Repeater(s) or Improvement be located? If it for each cell in the Range, then use code like

    Dim C As Range 'Put at the top of your module

    For Each C In rngTarg

    If C.Offset(0, 2) = "Repeater(s)" Or C.Offset(0, 2) = "Improvement" Then MsgBox "As you enter <" & C.Offset(0, 2) & "> in Student's Name Column in <" & SheetName & ">" _ & vbNewLine & "that is why you cannot enter Seat No.", vbInformation, "Information" C.ClearContents End If

    Next C

    Or, instead of looping, you could write your code that it only fires when the values are changing for a single cell instead of multiple cells:

    Private Sub Worksheet_Change(ByVal Target As Range)

        If Target.Cells.Count > 1 Then Exit Sub

       Select Case True

    ..... rest of code

    Or you can better explain what it is that you are doing, or share a workbook that has the structure required for the code to work.


    Friday, December 4, 2015 5:05 PM
  • Hi

    Bernie Deitrick

    You have solve my problem by using looping

    but I don't like

    I L O V E it

    Keep me in good books

    Saturday, December 5, 2015 5:34 AM