Rob342
07-15-2009, 05:59 AM
Hi
I am trying to extract the first 5 & 6 chars from a string in a cell to test various 6th digit chars.Using the left & mid function
If i use left(B30,6) this works fine directly in a cell but doesn't work in VBA
I have tried using VBA debug but the value always comes back as "".
The code i have works fine for picking up duplicates but i want to extract & do tests on the 1st 5 & especially the 6th char from the string ?
Here is the code i have with help from you guys, simon,xld.p45cal
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Dups As Long
Dim RTS As Long
Dim RTS1 As Long
Dim RTS2 As Long
If Not Block Then
If Target.Areas.Count > 1 Then Exit Sub
With Me.Range("B30:B45")
Dups = Application.WorksheetFunction.CountIf(Me.Range("B30:B45"), Target(1, 1).Value)
RTS = Evaluate("SumProduct(--(Left(B30:B45,5)=Left(" & Target(1, 1).Address & ",5)))")
RTS1 = Evaluate("SumProduct(--(Mid(B30:B45,6,1)=Mid(" & Target(1, 1).Address & ",6,1)))")
'RTS2 = RTS + RTS1
Select Case True
Case Dups > 1
' Check for complete duplicate of sro number
If MsgBox("RTS Code And Process Duplicated. Only A Process 3 Duplicate Is Allowed !" & vbNewLine & _
"Are You Really Sure You Want To Accept The Duplicate ?", vbYesNo) = vbYes Then
ActiveCell.Offset(1, 0).Select
End If
Case RTS > 1
' RTS check if 1st 5 chars are the same
If MsgBox("1st 5 Chars Of RTS Code Duplicated - Only A Process 3 Duplicate Is Allowed ! . Please Delete This Line !" & vbNewLine & _
"And Re-Enter A Different RTS Code ?", vbYesNo) = vbYes Then
ActiveCell.Offset(1, 0).Select
End If
Case RTS > 1 And RTS1 > 1
' RTS check if 1st 5 chars are the same and RTS1 6th char is the same !
If MsgBox("RTS Code & Process Duplicated - Different Vehicles ! . Please Delete This Line !" & vbNewLine & _
"And Re-Enter A Different RTS Code ?", vbNo) = vbNo Then
ActiveCell.Offset(1, 0).Select
End If
Case RTS2 > 1
' check if the 6th digit is the same as other input values
If MsgBox("RTS Code Duplicated. Please Check Process No !" & vbNewLine & _
"Are You Really Sure You Want To Accept The Duplicate ?", vbYesNo) = vbYes Then
ActiveCell.Offset(1, 0).Select
End If
End Select
End With
End If
End Sub
I am trying to extract the first 5 & 6 chars from a string in a cell to test various 6th digit chars.Using the left & mid function
If i use left(B30,6) this works fine directly in a cell but doesn't work in VBA
I have tried using VBA debug but the value always comes back as "".
The code i have works fine for picking up duplicates but i want to extract & do tests on the 1st 5 & especially the 6th char from the string ?
Here is the code i have with help from you guys, simon,xld.p45cal
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Dups As Long
Dim RTS As Long
Dim RTS1 As Long
Dim RTS2 As Long
If Not Block Then
If Target.Areas.Count > 1 Then Exit Sub
With Me.Range("B30:B45")
Dups = Application.WorksheetFunction.CountIf(Me.Range("B30:B45"), Target(1, 1).Value)
RTS = Evaluate("SumProduct(--(Left(B30:B45,5)=Left(" & Target(1, 1).Address & ",5)))")
RTS1 = Evaluate("SumProduct(--(Mid(B30:B45,6,1)=Mid(" & Target(1, 1).Address & ",6,1)))")
'RTS2 = RTS + RTS1
Select Case True
Case Dups > 1
' Check for complete duplicate of sro number
If MsgBox("RTS Code And Process Duplicated. Only A Process 3 Duplicate Is Allowed !" & vbNewLine & _
"Are You Really Sure You Want To Accept The Duplicate ?", vbYesNo) = vbYes Then
ActiveCell.Offset(1, 0).Select
End If
Case RTS > 1
' RTS check if 1st 5 chars are the same
If MsgBox("1st 5 Chars Of RTS Code Duplicated - Only A Process 3 Duplicate Is Allowed ! . Please Delete This Line !" & vbNewLine & _
"And Re-Enter A Different RTS Code ?", vbYesNo) = vbYes Then
ActiveCell.Offset(1, 0).Select
End If
Case RTS > 1 And RTS1 > 1
' RTS check if 1st 5 chars are the same and RTS1 6th char is the same !
If MsgBox("RTS Code & Process Duplicated - Different Vehicles ! . Please Delete This Line !" & vbNewLine & _
"And Re-Enter A Different RTS Code ?", vbNo) = vbNo Then
ActiveCell.Offset(1, 0).Select
End If
Case RTS2 > 1
' check if the 6th digit is the same as other input values
If MsgBox("RTS Code Duplicated. Please Check Process No !" & vbNewLine & _
"Are You Really Sure You Want To Accept The Duplicate ?", vbYesNo) = vbYes Then
ActiveCell.Offset(1, 0).Select
End If
End Select
End With
End If
End Sub