VBA help

[Emmily]

Hi, is there a macro that will produce the below result. For each team i want the count of entries per age criteria as reflected in row 1 and then i want the amount in (AUD) and then the number of entries which does not have a comment in col P and it value in AUD.

I know all of this can be done via formula, but i will have another 20 teams and the last age criteria will go to >90, so there will be a lot of formulas, hence it will slow the performance of the workbook.

Col L-P is raw data and R-S is FX data

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S
1		2-5				6-29
2	Team	No.of items	Value (AUD)	No. of items without Comments	Value (AUD)	No.of items	Value (AUD)	No. of items without Comments	Value (AUD)			Amount	CCY	Age	Source	Comments		FX RATES	Rate (AUD)
3	CMP1	1	11,593.66	1	5,796.83	0	0.00	0	0.00			8,268.57	AUD	1456	TRACES			AED	3.712435
4	TRACES											20,000.00	AUD	1248	TRACES			ANG	1.809243
5	LEHMAN											1,000.00	AUD	1248	TRACES			ARS	4.053867
6												4,417.80	GBP	3	CMP1	Test		ATS	10.203373
7												2,208.90	GBP	1018	CMP1			AUD	1
8												100,000.00	AUD	742	TRACES			BEF	29.912398
9												1,163.22	EUR	561	LEHMAN			BGN	1.450275
10												-3,320.14	EUR	561	LEHMAN			GBP	0.381053
11												9,646.51	EUR	561	LEHMAN	Test		BMD	1.01075
12												-12,618.80	EUR	561	LEHMAN			BRL	1.688256
13												476,017.76	EUR	561	LEHMAN			BSD	1.01075
14												-1,688,137.00	JPY	561	LEHMAN			BVD	2
15												7,187,517.00	JPY	561	LEHMAN			CAD	1.001098
16												-6,303,971.00	JPY	561	LEHMAN			CHF	0.957838
17												108,431.34	USD	561	LEHMAN
18
19
20
Sheet1

 

[Krishnakumar]

Hi,

What's your address of rngSource ? If it's start with C3:Px then the code should work. otherwise adjust the column numbers used in the code.

 

[Emmily]

Hi,

What's your address of rngSource ? If it's start with C3:Px then the code should work. otherwise adjust the column numbers used in the code.

Address of rngSource is A3:P, i tried playing with the column numbers but no luck

 

[Emmily]

Hi,

What's your address of rngSource ? If it's start with C3:Px then the code should work. otherwise adjust the column numbers used in the code.

Kris i fixed it. Thanks it works like charm. Thanks for your time on this.

 

[Emmily]

Hi,

What's your address of rngSource ? If it's start with C3:Px then the code should work. otherwise adjust the column numbers used in the code.

Kris in your code which part points to Col P

Why is the code not putting result in "No items without comments, have a look at the below for Traces and CMP1, the code is only picking up 3 trace items when there should be 4, also for CMP1 one item has no comments but the code is putting zero

Excel Workbook
	B	S	T	U	V
1		>90
2	Team	No. of items	Value (AUD)	No. of items without Comments	Value (AUD)
3	TRACES	3	121,000.00	0	0.00
4	CMP1	2	10,585.34	0	0.00
Sheet1

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
3	Category	Rec	Account	Value Date	Entry Date	Type	Amount	CCY	Age	Source	Ref1	Ref2	Ref3	Reference	Last Update	Comments
4	TEST	TEST	TEST	TEST	TEST	TEST	8268.57	AUD	1456	TRACES	TEST	TEST	TEST	TEST
5	TEST	TEST	TEST	TEST	TEST	TEST	20000	AUD	1248	TRACES	TEST	TEST	TEST	TEST
6	TEST	TEST	TEST	TEST	TEST	TEST	1000	AUD	1248	TRACES	TEST	TEST	TEST	TEST
7	TEST	TEST	TEST	TEST	TEST	TEST	4417.8	GBP	1019	CMP1	TEST	TEST	TEST	TEST		Test
8	TEST	TEST	TEST	TEST	TEST	TEST	2208.9	GBP	1018	CMP1	TEST	TEST	TEST	TEST
9	TEST	TEST	TEST	TEST	TEST	TEST	100000	AUD	742	TRACES	TEST	TEST	TEST	TEST
10	TEST	TEST	TEST	TEST	TEST	TEST	1163.22	EUR	561	LEHMAN	TEST	TEST	TEST	TEST
Rec

 

[Krishnakumar]

Hi,

If Len(Trim$(ka(i, 14))) = 0 Then

This line checks whether column P has comments or not. In your code replace 14 with 16.


Also confirm that there is no currency is missing.

Kris

 

[Emmily]

I changed to 16 and the code returned this, which is not correct, i should be getting 4 counts for Traces, see second screen shot below

Fx rates are correct

Excel Workbook
	B	S	T	U	V
1		>90
2	Team	No. of items	Value (AUD)	No. of items without Comments	Value (AUD)
3	TRACES	3	121,000.00	3	0.00
4	CMP1	2	10,585.34	1	0.00
Sheet1

This is what i should be getting

Excel Workbook
	B	S	T	U	V
1		>90
2	Team	No. of items	Value (AUD)	No. of items without Comments	Value (AUD)
3	TRACES	4	129,628.57	4	129,628.57
4	CMP1	2	10,585.34	1	3,528.45
Sheet1

 

[Emmily]

I changed this line to 8

If CSng(dic1.Item(ka(i, 8))) Then

Now i get this which is very close, but still not picking up the 4 Traces item, only 3 is being picked up

Excel Workbook
	B	S	T	U	V
1		>90
2	Team	No. of items	Value (AUD)	No. of items without Comments	Value (AUD)
3	TRACES	3	121,000.00	3	121,000.00
4	CMP1	2	10,585.34	1	3,528.45
5	LEHMAN	1	1,568.72	1	1,568.72
Sheet1

 

[Emmily]

Its not picking up this line

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
3	Category	Rec	Account	Value Date	Entry Date	Type	Amount	CCY	Age	Source	Ref1	Ref2	Ref3	Reference	Last Update	Comments
4	TEST	TEST	TEST	TEST	TEST	TEST	8268.57	AUD	1456	TRACES	TEST	TEST	TEST	TEST
Rec

 

[Krishnakumar]

Hi,

Here you go

Sub BTest()

    Dim ka, k, i As Long, c As Long, n As Long, Idx, m As Long
    Dim dic1 As Object, Fx, Age As String, dic2 As Object
    Dim Hdr, AgeGroup, r As Long, tmp, Flg As Boolean, t As Long
    Dim dblAmount   As Double
    Dim strCurrency As String
    Dim lngAge      As Long
    Dim strSource   As String
    Dim strComments As String
    
    
    '// adjust to suit
    Const SourceShtName         As String = "Rec"
    Const SourceDataRange       As String = "rngSource"
    Const StartRow              As Long = 2
'    Const FxDataRange           As String = "R3:S16"
    Const DestRange             As String = "B1"
    '//End


    Hdr = Array("No. of items", "Value (AUD)", "No. of items without Comments", "Value (AUD)")
    AgeGroup = Array("2-5", "6-29", "30-59", "60-89", ">90")

    Set dic1 = CreateObject("scripting.dictionary")
        dic1.comparemode = 1
    Set dic2 = CreateObject("scripting.dictionary")
        dic2.comparemode = 1

    With Worksheets(CStr(SourceShtName))
        ka = Intersect(.UsedRange, .Range("rngSource"))
    End With
    
    With Worksheets("FX")
        Fx = .Range("rngFX")
    End With
        
    With Worksheets("Sheet1")
        r = .Range("b" & .Rows.Count).End(xlUp).Row
        tmp = .Range("B3:B" & r)
    End With

    For i = 1 To UBound(Fx, 1)
        dic1.Item(Fx(i, 1)) = Fx(i, 2)
    Next

    For i = 1 To UBound(tmp, 1)
        dic2.Item(tmp(i, 1)) = i
    Next

    Age = ",{2,1;6,2;30,3;60,4;90,5}"

    ReDim k(1 To UBound(tmp, 1), 1 To 21)

    For i = StartRow To UBound(ka, 1)
        '//Adjust to suit
        dblAmount = CDbl(Trim$(ka(i, 7)))
        strCurrency = Trim$(ka(i, 8))
        lngAge = Trim$(ka(i, 9))
        strSource = Trim$(ka(i, 10))
        strComments = Trim$(ka(i, 16))
        '//
        Idx = Evaluate("=lookup(" & lngAge & Age & ")")
        If Not IsError(Idx) Then
            If dic2.exists(strSource) Then
                Flg = True
                t = dic2.Item(strSource)
                k(t, 1) = strSource
                k(t, Idx * 4 - 4 + 2) = k(t, Idx * 4 - 4 + 2) + 1
                If CSng(dic1.Item(strCurrency)) Then
                    k(t, Idx * 4 - 4 + 3) = k(t, Idx * 4 - 4 + 3) + dblAmount / dic1.Item(strCurrency)
                End If
                If Len(strComments) = 0 Then
                    k(t, Idx * 4 - 4 + 4) = k(t, Idx * 4 - 4 + 4) + 1
                    If CSng(dic1.Item(strCurrency)) Then
                        k(t, Idx * 4 - 4 + 5) = k(t, Idx * 4 - 4 + 5) + dblAmount / dic1.Item(strCurrency)
                    End If
                End If
            End If
        End If
    Next

    If Flg Then
        With Worksheets("Sheet1")
            .Rows(1).NumberFormat = "@"
            .Rows(2).WrapText = 1
            .Rows(2).Font.Bold = 1
            n = UBound(tmp, 1)
            With .Range(CStr(DestRange))
                .Resize(n + 2, 21).ClearContents
                m = 1
                For i = 0 To UBound(AgeGroup)
                    .Offset(, m).Value = AgeGroup(i)
                    .Offset(1, m).Resize(, 4).Value = Hdr
                    m = m + 4
                Next
                .Offset(1) = "Team"
                .Offset(2).Resize(n, 21).Value = k
                On Error Resume Next
                .Offset(2, 1).Resize(n, 20).SpecialCells(4).Value = 0
                On Error GoTo 0
            End With
        End With
    End If

End Sub

HTH

 

[Emmily]

I get a type mismatch on this line run time error 13

dblAmount = CDbl(Trim$(ka(i, 7)))