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

 

[Emmily]

Ok, by using the trim part its working, but i noticed one thing when i ran your code, it removes the the teams in Col A, and the code puts the teams there. I need the teams to be stationary as some teams might not be on the L:P but i still need to show them in the stats.

<table border="0" cellpadding="0" cellspacing="0" width="64"><col style="width: 48pt;" width="64"> <tbody><tr style="height: 14.4pt;" height="19"> <td style="height: 14.4pt; width: 48pt;" height="19" width="64">
</td></tr><tr style="height: 14.4pt;" height="19"><td style="height: 14.4pt;" height="19">
</td></tr><tr style="height: 14.4pt;" height="19"><td style="height: 14.4pt;" height="19">
</td></tr><tr style="height: 14.4pt;" height="19"><td style="height: 14.4pt;" height="19">
</td></tr></tbody></table>

 

[Krishnakumar]

Hi,

Here you go..

Excel Workbook
	A	B	C	D	E	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD
1	*	2-5	*	*	*	>90	*	*	*	*
2	*	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	TRACES	0	0	0	0	4	129268.6	4	129268.6	*	8,268.57	AUD	1456	TRACES			AED	3.712435
4	CMP1	1	11593.66	0	0	1	5796.832	1	5796.832	*	20,000.00	AUD	1248	TRACES			ANG	1.809243
5	LEHMAN	0	0	0	0	9	-162661	8	-168375	*	1,000.00	AUD	1248	TRACES			ATS	10.203373
6	*	*	*	*	*	*	*	*	*	*	4,417.80	GBP	3	CMP1	Test		AUD	1
7	*	*	*	*	*	*	*	*	*	*	2,208.90	GBP	1018	CMP1			BEF	29.912398
8	*	*	*	*	*	*	*	*	*	*	1,00,000.00	AUD	742	TRACES			JPY	1.450275
9	*	*	*	*	*	*	*	*	*	*	1,163.22	EUR	561	LEHMAN			GBP	0.381053
10	*	*	*	*	*	*	*	*	*	*	-3,320.14	EUR	561	LEHMAN			BMD	1.01075
11	*	*	*	*	*	*	*	*	*	*	9,646.51	EUR	561	LEHMAN	Test		EUR	1.688256
12	*	*	*	*	*	*	*	*	*	*	-12,618.80	EUR	561	LEHMAN			BSD	1.01075
13	*	*	*	*	*	*	*	*	*	*	4,76,017.76	EUR	561	LEHMAN			BVD	2
14	*	*	*	*	*	*	*	*	*	*	-16,88,137.00	JPY	561	LEHMAN			CAD	1.001098
15	*	*	*	*	*	*	*	*	*	*	71,87,517.00	JPY	561	LEHMAN			USD	0.957838
16	*	*	*	*	*	*	*	*	*	*	-63,03,971.00	JPY	561	LEHMAN			*	*
17	*	*	*	*	*	*	*	*	*	*	1,08,431.34	USD	561	LEHMAN
Sheet1

 

[Krishnakumar]

Hi,

Try

Sub kTest()
    
    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
    
    '// adjust to suit
    Const SourceShtName         As String = "Sheet1"
    Const SourceDataRange       As String = "L:P"
    Const StartRow              As Long = 3
    Const FxDataRange           As String = "R3:S16"
    Const DestRange             As String = "A1"
    '//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(CStr(SourceDataRange)))
        Fx = .Range(CStr(FxDataRange))
        r = .Range("a" & .Rows.Count).End(xlUp).Row
        tmp = .Range("a3:a" & 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)
    
    c = 23 - Range(CStr(SourceDataRange)).Column
    
    For i = StartRow To UBound(ka, 1)
        Idx = Evaluate("=lookup(" & ka(i, 3) & Age & ")")
        If Not IsError(Idx) Then
            If dic2.exists(ka(i, 4)) Then
                Flg = True
                t = dic2.Item(ka(i, 4))
                k(t, 1) = ka(i, 4)
                k(t, Idx * 4 - 4 + 2) = k(t, Idx * 4 - 4 + 2) + 1
                If CSng(dic1.Item(ka(i, 2))) Then
                    k(t, Idx * 4 - 4 + 3) = k(t, Idx * 4 - 4 + 3) + CSng(ka(i, 1) / dic1.Item(ka(i, 2)))
                End If
                If Len(Trim$(ka(i, 5))) = 0 Then
                    k(t, Idx * 4 - 4 + 4) = k(t, Idx * 4 - 4 + 4) + 1
                    If CSng(dic1.Item(ka(i, 2))) Then
                        k(t, Idx * 4 - 4 + 5) = k(t, Idx * 4 - 4 + 5) + CSng(ka(i, 1) / dic1.Item(ka(i, 2)))
                    End If
                End If
            End If
        End If
    Next
    
    If Flg Then
        With Worksheets(CStr(SourceShtName))
            If c > 0 Then .Cells(1).Resize(, c).EntireColumn.Insert
            .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).Resize(n, 21).SpecialCells(4).Value = 0
                On Error GoTo 0
            End With
        End With
    End If
        
End Sub

HTH

 

[Emmily]

Great, this works. If i was going to add named ranges to the data source and FX would that be too difficult to change

So W:AA becomes rngSource
AC3:AD16 becomes rngFX

This will give me flexibility to put Source data and Fx on another sheet if need be

Const SourceDataRange As String = "W:AA"
Const FxDataRange As String = "AC3:AD16"

 

[Krishnakumar]

Great, this works.

You are welcome !

If i was going to add named ranges to the data source and FX would that be too difficult to change

So W:AA becomes rngSource
AC3:AD16 becomes rngFX

This will give me flexibility to put Source data and Fx on another sheet if need be

Const SourceDataRange As String = "W:AA"
Const FxDataRange As String = "AC3:AD16"

Let the sourceshtname there.

replace the datarange and fxrange with

ka = Intersect(.UsedRange, .Range("rngSource"))
Fx = .Range("rngFX")

 

[Emmily]

You are welcome !

Let the sourceshtname there.

replace the datarange and fxrange with

ka = Intersect(.UsedRange, .Range("rngSource"))
Fx = .Range("rngFX")

Kris, i notice when i repeat running the macro, the code repeats the age criterias after >90 criteria, it just keeps expanding everytime i run the code.

 

[Emmily]

Ok, i fixed that by putting the const as named range.

c = 23 - Range(SourceDataRange).Column.

Kris whilst on this subject, i have to do the same thing with asset data this time, using the same age critierias but not Exchange rates, how can i use your code for the below. The data is a bit different therefore i have posted a formula result so you can what needs to be done.

Excel Workbook
	A	R	S	T	U	V	W	AE	AF	AH
1		>90
2	Team	No. of items	Units	No. of items without Comments	Units		Source	Exception	Age Break	Comments
3	TRANS	1	-149,000.00	0	0.00		TRANS	-149,000.00	1255	TEST
4	LEHMAN	2	-6,223,937.80	1	263.20		LEHMAN	-6,224,201.00	1081	Test
5	AMORTISE	2	-3,884.94	2	-3,884.94		LEHMAN		1081	Test
6							LEHMAN		1081	Test
7							LEHMAN		1081	Test
8							LEHMAN	263.20	1080
9							AMORTISE	-1,294.98	812
10							AMORTISE	-2,589.96	812
11
Sheet2

 

[Krishnakumar]

Hi,

Try

Sub kTest()
    
    Dim ka, k, i As Long, c As Long, n As Long, Idx, m As Long
    Dim dic As Object, Age As String
    Dim Hdr, AgeGroup, r As Long, tmp, Flg As Boolean, t As Long
    
    '// adjust to suit
    Const SourceShtName         As String = "Sheet1"
    Const SourceDataRange       As String = "W:Z"
    Const StartRow              As Long = 3
    Const DestRange             As String = "A1"
    '//End
    
    
    Hdr = Array("No. of items", "Units", "No. of items without Comments", "Units")
    AgeGroup = Array("2-5", "6-29", "30-59", "60-89", ">90")
    
    Set dic = CreateObject("scripting.dictionary")
        dic.comparemode = 1
        
    With Worksheets(CStr(SourceShtName))
        ka = Intersect(.UsedRange, .Range(CStr(SourceDataRange)))
        r = .Range("a" & .Rows.Count).End(xlUp).Row
        tmp = .Range("a3:a" & r)
    End With
    
    For i = 1 To UBound(tmp, 1)
        If Len(Trim$(tmp(i, 1))) Then dic.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)
        If Len(Trim$(ka(i, 2))) Then
            Idx = Evaluate("=lookup(" & ka(i, 3) & Age & ")")
            If Not IsError(Idx) Then
                If dic.exists(ka(i, 1)) Then
                    Flg = True
                    t = dic.Item(ka(i, 1))
                    k(t, 1) = ka(i, 1)
                    k(t, Idx * 4 - 4 + 2) = k(t, Idx * 4 - 4 + 2) + 1
                    k(t, Idx * 4 - 4 + 3) = k(t, Idx * 4 - 4 + 3) + ka(i, 2)
                    If Len(Trim$(ka(i, 4))) = 0 Then
                        k(t, Idx * 4 - 4 + 4) = k(t, Idx * 4 - 4 + 4) + 1
                        k(t, Idx * 4 - 4 + 5) = k(t, Idx * 4 - 4 + 5) + ka(i, 2)
                    End If
                End If
            End If
        End If
    Next
    
    If Flg Then
        With Worksheets(CStr(SourceShtName))
            .Rows(1).NumberFormat = "@"
            .Rows(2).WrapText = 1
            .Rows(2).Font.Bold = 1
            n = dic.Count
            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).Resize(n, 21).SpecialCells(4).Value = 0
                On Error GoTo 0
            End With
        End With
    End If
        
End Sub

HTH

 

[Emmily]

Kris, when i tried to use a named range "Test" then the code did not work, if you look at my raw data i hid some columns which were not important, but my real data look similar to the below, so not sure how your code looks up this data. I put the named range in Sheet 3, i then tries to do this, ran the macro but nothing happened.

ka = Intersect(Sheet3.UsedRange, Sheet3.Range("Test"))

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L
2	Source	Case No.	Value Date	Security Code	Description	Ccy Code	Ledg Stmt	Units	Exception	Age Break	Last Update	Comments
3	TRANS	680622	39365	INPUSD	Test		Ledg	149000	-149000	1255	8-Sep-10	TEST
4	LEHMAN	550933	39539	OCV	Test	AUD	Ledg	751981	-6224201	1081	7-May-09	Test
5	LEHMAN	550933	39539	OCV	Test	AUD	Ledg	4752133		1081	7-May-09	Test
6	LEHMAN	550933	39539	OCV	Test	AUD	Ledg	374763		1081	7-May-09	Test
7	LEHMAN	550933	39539	OCV	Test	AUD	Ledg	140761		1081	7-May-09	Test
8	LEHMAN	555030	39540	OCV	Test	AUD	Stmt	75000	263.2	1080	29-May-09
9	AMORTISE	698707	39808	CW250335	Test		Ledg	1294.98	-1294.98	812	23-Aug-10
10	AMORTISE	698710	39808	CWL25035	Test		Ledg	2589.96	-2589.96	812	23-Aug-10
Sheet3

 

[Emmily]

I ran your code again, changed this to this, but the result is not the same as the orignal post. The code removes Trans and replace with zero

ka = Intersect(Sheet3.UsedRange, Sheet3.Range("Test"))

Excel Workbook
	A	R	S	T	U
1		>90
2	Team	No. of items	Units	No. of items without Comments	Units
3	0	0	0.00	0	0.00
4	LEHMAN	5	2,758,762.00	0	0.00
5	AMORTISE	2	1,397,417.00	0	0.00
Sheet2