kuldeepjainesl
Member
I have a code that used to work and it worked great till certain type of string came to process. What this code is expected to do ? let me explain
This code search for the last set of numeric numbers in a text string and then try to make ranges out of those last set of numbers. In case any suffix was there in string, it again add that to the ranges. i have attached a sample sheet. in sheet 1 Green cells are showing the intended working of code but it is failing for the red cell strings.
This code search for the last set of numeric numbers in a text string and then try to make ranges out of those last set of numbers. In case any suffix was there in string, it again add that to the ranges. i have attached a sample sheet. in sheet 1 Green cells are showing the intended working of code but it is failing for the red cell strings.
Code:
Sub Traiter()
Const Dest = "G1" 'Where write result
Dim LastLig As Long, i As Long, k As Long, io As Long
Dim StrIni As String, StrFin As String
Dim Deb As Boolean
Dim Tb
Application.ScreenUpdating = False
'Initial Datas are in worksheet Sheet1 at columns A & B
With Sheet1
LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A1:B" & LastLig).Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes
Tb = .Range("A2:B" & LastLig + 1)
End With
ReDim Res(1 To 2, 1 To 1)
io = 1
For i = 1 To LastLig - 1
StrFin = Txt(Tb(i + 1, 1))
StrIni = Txt(Tb(i, 1))
If StrFin = StrIni And Num(Tb(i + 1, 1), StrFin) = Num(Tb(i, 1), StrIni) + 1 Then
If Deb Then io = i
Deb = False
Else
k = k + 1
ReDim Preserve Res(1 To 2, 1 To k)
Res(1, k) = Tb(io, 1)
Res(2, k) = Tb(i, 2)
Deb = True
io = i + 1
End If
Next i
'Result wrote in worksheet Sheet2 at the cell DEST (cf Constant definition)
If k > 0 Then Sheet2.Range(Dest).Resize(k, 2) = Application.Transpose(Res)
End Sub
Private Function Txt(ByVal Str As String) As String
Dim Rg As Object
Set Rg = CreateObject("VBscript.RegExp")
With Rg
.Pattern = "(\d)(.*)"
.Global = True
Txt = .Replace(Str, "")
End With
Set Rg = Nothing
End Function
Private Function Num(ByVal Str As String, Pref As String) As Double
If Str <> "" Then Num = Val(Replace(Str, Pref, ""))
End Function