Posts by quant

Sub test() 
	'Declaring Variables
    Dim a, i As Long, temp, x, result 
	'Assign values in current region to the variable 'a' in a given sheet
    a = Range("a1").CurrentRegion.Value 
	'Creating a two-dimensional array with the number of items in a and 5 items.
    Redim Preserve a(1 To UBound(a, 1), 1 To 5) 
	'Looping through each items in variable a
    For i = 1 To UBound(a, 1) 
		'Calling Check Pattern function in order to assign the value for the temp
        temp = CheckPattern(a(i, 1)) 
		'split the string based on "|" in the string which is in temp.
        x = Split(temp, "|") 
		'To see if the x is having one item or more than one item, and assigning values into the array.
        If UBound(x) = 1 Then 
            a(i, 2) = x(0) 
            a(i, 3) = x(1) 
            a(i, 5) = a(i, 1) 
        Else 
            a(i, 2) = x(0) 
            a(i, 3) = x(1) 
            a(i, 4) = x(2) 
            a(i, 5) = x(0) & x(1) 
        End If 
    Next 
	'Call Function Get Grouped passing the array a
    x = GetGrouped(a) 
	'Fetch the series from the given values
    x = GetSeries(x(0), x(1), 100) 
	'Provide the result based on the function call, GetAligned passing in array and x.
    result = GetAligned(a, x) 
	'It make sures that screen doesn't flicker
    Application.ScreenUpdating = False 
    For i = 1 To UBound(result, 1) 
        If result(i, 1) = "" Then Rows(i).Insert 
    Next 
    Range("a1").Resize(UBound(result, 1), 2).Value = result 
	'Resetting above to make sure. Screen responds to user input
    Application.ScreenUpdating = True 
End Sub 
 
 'Checks for the pattern in the text passed to it
Private Function CheckPattern(ByVal txt As String) As String 
    Dim Fnum, Lnum 
	'Creates a Regular Expression
    With CreateObject("VBScript.RegExp") 
		'Providing a pattern for which string needs to match.
        .Pattern = "^(\D+)(\d+)$" 
        .IgnoreCase = True 
        If .test(txt) Then 
		'Returns this value
            CheckPattern = .Replace(txt, "$1|$2") 
        Else 
			'If above pattern does not match then it comes to this loop and creates a new pattern
            .Pattern = "^(\D+)(\d+) ?\-(.*\D)?(\d+)$" 
            If .test(txt) Then 
				'Replaces values in the string passed
                Fnum = .Replace(txt, "$2") 
                Lnum = .Replace(txt, "$4") 
                If Len(Fnum) <> Len(Lnum) Then 
					'Assigns the Length of the String based on .. replace
                    Lnum = Application.Replace(Fnum _
                    , Len(Fnum) - Len(Lnum) + 1, Len(Fnum), Lnum) 
                End If 
                CheckPattern = .Replace(txt, "$1|") & Fnum & "|" & Lnum 
            Else 
			'If above pattern does not match then it comes to this loop and creates a new pattern			
                .Pattern = "^(\D+)(\d+) DEN (\d+) .*$" 
                If .test(txt) Then 
                    Fnum = .Replace(txt, "$2") 
                    Lnum = .Replace(txt, "$3") 
                    If Len(Fnum) <> Len(Lnum) Then 
                        Lnum = Application.Replace(Fnum _ 
                        , Len(Fnum) - Len(Lnum) + 1, Len(Fnum), Lnum) 
                    End If 
                    CheckPattern = .Replace(txt, "$1|") & Fnum & "|" & Lnum 
                End If 
            End If 
        End If 
    End With 
End Function 
 
 
 'Groups items which are in the given array, based on unique items available/
Private Function GetGrouped(a As Variant) As Variant 
    Dim i As Long, w(), myNum 
    With CreateObject("Scripting.Dictionary") 
        .comparemode = 1 
        For i = 1 To UBound(a, 1) 
            If Not .exists(a(i, 2)) Then 
                Redim w(1 To 4, 1 To 1) 
                w(1, 1) = a(i, 3) 
                w(2, 1) = IIf(a(i, 4) = "", a(i, 3), a(i, 4)) 
                w(3, 1) = a(i, 3) 
                .Item(a(i, 2)) = w 
            Else 
                w = .Item(a(i, 2)) 
                Redim Preserve w(1 To 4, 1 To UBound(w, 2) + 1) 
                w(1, UBound(w, 2)) = a(i, 3) 
                w(2, UBound(w, 2)) = IIf(a(i, 4) = "", a(i, 3), a(i, 4)) 
                w(3, UBound(w, 2)) = _ 
                w(2, UBound(w, 2)) - Val(w(1, UBound(w, 2) - 1)) 
                .Item(a(i, 2)) = w 
            End If 
        Next 
        GetGrouped = VBA.Array(.keys, .items) 
    End With 
End Function 
 
 'fetches the series from the given elements.
Function GetSeries(x, y, myLimit) 
    Dim i As Long, ii As Long, iii As Long 
    With CreateObject("System.Collections.ArrayList") 
        For i = LBound(x) To UBound(x) 
            If UBound(y(i), 2) = 1 Then 
                For iii = y(i)(1, 1) To y(i)(2, 1) 
                    .Add x(i) & iii 
                Next 
            Else 
                .Add x(i) & y(i)(1, 1) 
                For ii = 2 To UBound(y(i), 2) 
                    If y(i)(2, ii) > y(i)(2, ii - 1) And y(i)(3, ii) < myLimit Then 
                        For iii = y(i)(2, ii - 1) + 1 To y(i)(2, ii) 
                            .Add x(i) & iii 
                        Next 
                    Else 
                        .Add x(i) & y(i)(1, ii) 
                    End If 
                Next 
            End If 
        Next 
        GetSeries = .ToArray 
    End With 
End Function 
 
'Aligns the values in the given array.
Function GetAligned(p, x) 
    Dim i As Long, temp 
    Redim a(1 To UBound(x) + 1, 1 To 2) 
    With CreateObject("Scripting.Dictionary") 
        For i = 0 To UBound(x) 
            .Item(x(i)) = i + 1 
            a(i + 1, 2) = x(i) 
        Next 
        For i = 1 To UBound(p, 1) 
            temp = p(i, 2) & p(i, 3) 
            If .exists(temp) Then a(.Item(temp), 1) = p(i, 1) 
        Next 
        GetAligned = a 
    End With 
End Function

[TR]
  [TD="class: xl22, width: 64"]  date
[/TD]
  [TD="class: xl22, width: 64"]description[/TD]
  [TD="class: xl22, width: 64"]amount[/TD]
  [TD="class: xl25, width: 64, align: right"]1000[/TD]
 [/TR]
 [TR]
  [TD="class: xl23, width: 64"]01.12.2011[/TD]
  [TD="class: xl23, width: 64"]supermarket[/TD]
  [TD="class: xl24, width: 64"]-10[/TD]
  [TD="align: right"]990[/TD]
 [/TR]
 [TR]
  [TD="class: xl23, width: 64"]02.12.2012[/TD]
  [TD="class: xl23, width: 64"]wages[/TD]
  [TD="class: xl24, width: 64"]1000[/TD]
  [TD="align: right"]1990[/TD]
 [/TR]
 [TR]
  [TD="class: xl23, width: 64"]04.12.2011[/TD]
  [TD="class: xl23, width: 64"]butcher[/TD]
  [TD="class: xl24, width: 64"]-5[/TD]
  [TD="align: right"]1985[/TD]
 [/TR]
 [TR]
  [TD="class: xl23, width: 64"]06.12.2011[/TD]
  [TD="class: xl23, width: 64"]child benefit[/TD]
  [TD="class: xl24, width: 64"] 80  [/TD]
  [TD="align: right"]2065[/TD]
[/TR]