Help in Merging Codes [Solved/Closed]

Report
Posts
77
Registration date
Saturday September 5, 2015
Status
Member
Last seen
March 8, 2017
-
Posts
77
Registration date
Saturday September 5, 2015
Status
Member
Last seen
March 8, 2017
-
Hi
I need help in the following VBA (Macro Codes) in Excel 2013

Code 1:
Private Sub Worksheet_Change(ByVal Target As Range)

Dim Invalid As Boolean

On Error Resume Next

If Intersect(Target, Me.Range("B2:B1000")) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub

Application.EnableEvents = False

If Left(Target, 1) Like "[a-zA-Z]" And Len(Mid(Target, 2, Len(Target))) > 0 And Not Mid(Target, 2, Len(Target)) Like "*[!0-9]*" Then
Target = WorksheetFunction.Replace(UCase(Target), 2, 0, "-")
Application.EnableEvents = True
Exit Sub
End If

If Left(Target, 2) Like "[a-zA-Z][a-zA-Z]" And Len(Mid(Target, 3, Len(Target))) > 0 And Not Mid(Target, 3, Len(Target)) Like "*[!0-9]*" Then
Target = WorksheetFunction.Replace(UCase(Target), 3, 0, "-")
Else
Invalid = True
End If

If Invalid = True Then
Target.Select
MsgBox "Entered Value " & Target & " is Wrong" & vbNewLine & "Please Enter Right Value", vbCritical, "Wrong Input"
Target.ClearContents
End If

Application.EnableEvents = True

End Sub

--------------------------------------------------------------------------------

Code 2:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Me.Range("C2:C1000")) Is Nothing Then Exit Sub

On Error GoTo ReEnableEvents
Application.EnableEvents = False
Dim regExp As Object
Dim strTarg As String
Dim i As Long
Dim strPattern As String
Dim arrTarg(1 To 4) As String
Dim lngMidChrs As Long


'Test in upper case and if correct characters then convert to Proper case"
If UCase(Trim(Target.Value)) = "APPLIED FOR" Then
Target.Value = WorksheetFunction.Proper(Trim(Target.Value))
GoTo ReEnableEvents 'Finished processing because "Applied for" entered
End If

Set regExp = CreateObject("VBScript.RegExp")

'Convert alpha characters to upper case and remove spaces and slashes (if any)
strTarg = UCase(Replace((Replace(Target.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
Target.Value = Left(strTarg, 3) & "/" & Mid(strTarg, 4, 3) & "/" & 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
Target.Value = Left(strTarg, 3) & "/" & Mid(strTarg, 4, 4) & "/" & Mid(strTarg, 8, 4) & "/" & Mid(strTarg, 12, 4)
End If

Else
Target.Select
MsgBox "Error! Re-enter the data in one of following formats" _
& vbCrLf & Chr(9) & "Applied for" _
& vbCrLf & Chr(9) & "AAA/AAA/9999/9999 or" _
& vbCrLf & Chr(9) & "AAA/AAAA/9999/9999" _
& vbCrLf & "Where" & Chr(9) & "A is an alpha character and" _
& vbCrLf & Chr(9) & "9 is a numeric character."
End If

ReEnableEvents:
If Err.Number <> 0 Then
MsgBox "Error occurred in Private Sub Worksheet_Change." _
& vbCrLf & "Refer to Administrator of this workbook."
End If
Application.EnableEvents = True
End Sub
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." _
& vbCrLf & "Refer to Administrator of this workbook."
End If
Application.EnableEvents = True
End Function


-----------------------------------------------------------------------------

Code 3:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim str() As String, bFound As Boolean
Dim SoDo() As String
Dim j As Long

bFound = False
If Intersect(Target, Me.Range("D2:D1000")) Is Nothing Then Exit Sub
On Error GoTo Errhandler
Application.EnableEvents = False

SoDo = Split("s/o, d/o, s /o, s / o, s/ o, d /o, d / o, d/ o", ", ")
For j = 1 To UBound(SoDo) + 1
If InStr(1, WorksheetFunction.Trim(Target), SoDo(j - 1)) Then
Target = Replace(WorksheetFunction.Trim(Target), SoDo(j - 1), "/", 1)
Exit For
End If
Next j

str = Split(Target.Value, "/")
For i = 0 To UBound(str)
str(i) = Trim(str(i))
If Left(LCase(str(i)), 6) = "repeat" Then
str(i) = "Repeater(s)"
bFound = True
End If
Next
If Application.CountA(str) > 1 Or bFound Then
If Application.CountA(str) > 1 Then
Target.Value = StrConv(Trim(str(0)) & " / " & Chr(10) & Trim(str(1)), vbProperCase)
ElseIf bFound Then
Target.Value = str(0)
End If
Target.Font.Name = "Times New Roman"
Target.Font.Size = 10
End If
Errhandler:
Application.EnableEvents = True
End Sub


----------------------------------------------------------------------------

Thanks & Regards

2 replies

Not much to go in in terms of an actual question but could this be what you mean:

In place of the msgbox put your code.

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Me.Range("B2:B1000")) Is Nothing Then
MsgBox ("Do Range B stuff")

ElseIf Not Intersect(Target, Me.Range("C2:C1000")) Is Nothing Then
MsgBox ("Do Range C stuff")

ElseIf Not Intersect(Target, Me.Range("D2:D1000")) Is Nothing Then
MsgBox ("Do Range D stuff")

Else
Exit Sub
End If

End Sub

Posts
77
Registration date
Saturday September 5, 2015
Status
Member
Last seen
March 8, 2017
1
Sorry this is not a valid answer