VBA help

Emmily

Emmily

Well-known Member
Joined
Oct 5, 2008
Messages
676
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
ABCDEFGHIJKLMNOPQRS
12-56-29
2TeamNo.of itemsValue (AUD)No. of items without CommentsValue (AUD)No.of itemsValue (AUD)No. of items without CommentsValue (AUD)AmountCCYAgeSourceCommentsFX RATESRate (AUD)
3CMP1111,593.6615,796.8300.0000.008,268.57AUD1456TRACESAED3.712435
4TRACES20,000.00AUD1248TRACESANG1.809243
5LEHMAN1,000.00AUD1248TRACESARS4.053867
64,417.80GBP3CMP1TestATS10.203373
72,208.90GBP1018CMP1AUD1
8100,000.00AUD742TRACESBEF29.912398
91,163.22EUR561LEHMANBGN1.450275
10-3,320.14EUR561LEHMANGBP0.381053
119,646.51EUR561LEHMANTestBMD1.01075
12-12,618.80EUR561LEHMANBRL1.688256
13476,017.76EUR561LEHMANBSD1.01075
14-1,688,137.00JPY561LEHMANBVD2
157,187,517.00JPY561LEHMANCAD1.001098
16-6,303,971.00JPY561LEHMANCHF0.957838
17108,431.34USD561LEHMAN
18
19
20
Sheet1
 
Sort by date Sort by votes

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Krishnakumar said:
Hi,

replace StartRow = 3 with StartRow = 2

HTH
Click to expand...

No that did not work. Could you please do a test by putting the below source data in sheet3, create a named range "rngTest" then use this. When i run the code nothing happens.

Const SourceShtName As String = "Sheet2"
Const SourceDataRange As String = "rngTest"
Const StartRow As Long = 3
Const DestRange As String = "A1"

Excel Workbook
ABCDEFGHIJKL
1
2SourceCase No.Value DateSecurity CodeDescriptionCcy CodeLedg StmtUnitsExceptionAge BreakLast UpdateComments
3TRANS68062210-Oct-07INPUSDTestLedg149,000.00-149,000.0012558-Sep-10TEST
4LEHMAN5509331-Apr-08OCVTestAUDLedg751,981.00-6,224,201.0010817-May-09Test
5LEHMAN5509331-Apr-08OCVTestAUDLedg4,752,133.0010817-May-09Test
6LEHMAN5509331-Apr-08OCVTestAUDLedg374,763.0010817-May-09Test
7LEHMAN5509331-Apr-08OCVTestAUDLedg140,761.0010817-May-09Test
8LEHMAN5550302-Apr-08OCVTestAUDStmt75,000.00263.20108029-May-09
9AMORTISE69870726-Dec-08CW250335TestLedg1,294.98-1,294.9881223-Aug-10
10AMORTISE69871026-Dec-08CWL25035TestLedg2,589.96-2,589.9681223-Aug-10
Sheet3
 
Upvote 0
Did that, but nothing happens, this the code i have

Code: 
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 = "Sheet3"
    Const SourceDataRange       As String = "rngTest"
    Const StartRow              As Long = 3
    Const DestRange             As String = "A1"

    
    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(Sheet3.UsedRange, Sheet3.Range(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
 
Upvote 0
Hi,

Try

Code: 
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 = "Sheet3"
    Const SourceDataRange       As String = "rngTest"
    Const StartRow              As Long = 2
    Const DestRange             As String = "A1"

    
    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(SourceDataRange))
    End With
    
    With Worksheets("Sheet2") '<<===adjust to suit
        r = .Range("a" & .Rows.Count).End(xlUp).Row
        tmp = .Range("a3:a" & r) 'your team list in destination sheet
    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, 9))) Then 'Exception column
            Idx = Evaluate("=lookup(" & ka(i, 10) & Age & ")") 'age column
            If Not IsError(Idx) Then
                If dic.exists(ka(i, 1)) Then 'source col
                    Flg = True
                    t = dic.Item(ka(i, 1))
                    k(t, 1) = ka(i, 1) 'source col
                    k(t, Idx * 4 - 4 + 2) = k(t, Idx * 4 - 4 + 2) + 1 'count items(Exception col)
                    k(t, Idx * 4 - 4 + 3) = k(t, Idx * 4 - 4 + 3) + ka(i, 9) 'sum units(Exception col)
                    If Len(Trim$(ka(i, 12))) = 0 Then 'comments col
                        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, 9) 'sum units w/o comments(Exception col)
                    End If
                End If
            End If
        End If
    Next
    
    If Flg Then
        With Worksheets("Sheet2") '<<==== adjust to suit
            .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
 
Last edited:
Upvote 0
Excellent that works. We will need to do the same for the Cash aswell, i tried playing with the numbers in code but didnt work.

This is data layout for Cash, named range ="rngSource" Source Sheets "Rec"

The Fx is on another sheet called FX named range "rngFX")

Excel Workbook
CDEFGHIJKLMNOP
3AccountValue DateEntry DateTypeAmountCCYAgeSourceRef1Ref2Ref3ReferenceLast UpdateComments
4TESTTESTTESTTEST8268.57AUD1456TRACESTESTTESTTESTTEST9-Jun-10TEST
5TESTTESTTESTTEST20000AUD1248TRACESTESTTESTTESTTEST9-Jun-10TEST
6TESTTESTTESTTEST1000AUD1248TRACESTESTTESTTESTTEST9-Jun-10TEST
7TESTTESTTESTTEST4417.8GBP1019CMP1TESTTESTTESTTEST22-Feb-11TEST
8TESTTESTTESTTEST2208.9GBP1018CMP1TESTTESTTESTTEST22-Feb-11TEST
9TESTTESTTESTTEST100000AUD742TRACESTESTTESTTESTTEST15-Mar-10TEST
10TESTTESTTESTTEST1163.22EUR561LEHMANTESTTESTTESTTEST6-Apr-10TEST
Rec


This is the code i tried to ammend

Code: 
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

    '// adjust to suit
    Const SourceShtName         As String = "Rec"
    Const SourceDataRange       As String = "rngSource"
    Const StartRow              As Long = 3
'    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)

    c = 23 - Range(SourceDataRange).Column

    For i = StartRow To UBound(ka, 1)
        Idx = Evaluate("=lookup(" & ka(i, 7) & Age & ")")
        If Not IsError(Idx) Then
            If dic2.exists(ka(i, 8)) Then
                Flg = True
                t = dic2.Item(ka(i, 8))
                k(t, 8) = ka(i, 8)
                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, 14))) = 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("Sheet1")
            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, 1).Resize(n, 20).SpecialCells(4).Value = 0
                On Error GoTo 0
            End With
        End With
    End If

End Sub
 
Upvote 0
Hi,

Not tested.

try by replace
Rich (BB code): 
CSng(ka(i, 1) / dic1.Item(ka(i, 2)))

with

Rich (BB code): 
CSng(ka(i, 5) / dic1.Item(ka(i, 2)))
 
Upvote 0
Hi,

try

Code: 
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

    '// adjust to suit
    Const SourceShtName         As String = "Rec"
    Const SourceDataRange       As String = "rngSource"
    Const StartRow              As Long = 3
'    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)

    'c = 23 - Range(SourceDataRange).Column

    For i = StartRow To UBound(ka, 1)
        Idx = Evaluate("=lookup(" & ka(i, 7) & Age & ")")
        If Not IsError(Idx) Then
            If dic2.exists(ka(i, 8)) Then
                Flg = True
                t = dic2.Item(ka(i, 8))
                k(t, 1) = ka(i, 8)
                k(t, Idx * 4 - 4 + 2) = k(t, Idx * 4 - 4 + 2) + 1
                If CSng(dic1.Item(ka(i, 6))) Then
                    k(t, Idx * 4 - 4 + 3) = k(t, Idx * 4 - 4 + 3) + CSng(ka(i, 5) / dic1.Item(ka(i, 6)))
                End If
                If Len(Trim$(ka(i, 14))) = 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, 5) / dic1.Item(ka(i, 6)))
                    End If
                End If
            End If
        End If
    Next

    If Flg Then
        With Worksheets("Sheet1")
            '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, 1).Resize(n, 20).SpecialCells(4).Value = 0
                On Error GoTo 0
            End With
        End With
    End If

End Sub

HTH
 
Upvote 0
Nope that did not work, i ran the code but nothing happened. Did you do a test at your end?

Note the highlighted columns are the ones i need, so the code must look at this.

Excel Workbook
ABCDEFGHIJKLMNOP
3CategoryRecAccountValue DateEntry DateTypeAmountCCYAgeSourceRef1Ref2Ref3ReferenceLast UpdateComments
4NOMSCASH NOMSTESTTESTTESTTEST8268.57AUD1456TRACESTESTTESTTESTTEST9-Jun-10TEST
5NOMSCASH NOMSTESTTESTTESTTEST20000AUD1248TRACESTESTTESTTESTTEST9-Jun-10TEST
6NOMSCASH NOMSTESTTESTTESTTEST1000AUD1248TRACESTESTTESTTESTTEST9-Jun-10TEST
7BNPPINTLCASH BNPP_AMP1TESTTESTTESTTEST4417.8GBP1019CMP1TESTTESTTESTTEST22-Feb-11TEST
8BNPPINTLCASH BNPP_AMP1TESTTESTTESTTEST2208.9GBP1018CMP1TESTTESTTESTTEST22-Feb-11TEST
9NOMSCASH NOMSTESTTESTTESTTEST100000AUD742TRACESTESTTESTTESTTEST15-Mar-10TEST
10SUSPENSECASH DESTESTTESTTESTTEST1163.22EUR561LEHMANTESTTESTTESTTEST6-Apr-10TEST
Rec
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question Question
Alternative to complex SumProduct to rank data by specific variable
Replies
3
Views
766
Peter_SSs
Peter_SSs
M
  • Solved
VBA Help - Duplicate & Unwanted Data Removal
Replies
6
Views
959
MoonDancer
M
A
  • Solved
why the code is slow despite of using advanced filter with simple data
2 3
Replies
23
Views
426
abdelfattah
A
Emka
  • Question Question
Web Scrap on Chrome via VBA
Replies
0
Views
140
Emka
Emka
N
  • Question Question
Data Transformation using VBA like subtotal
Replies
1
Views
146
Domenic
D

Forum statistics

Threads
1,224,566
Messages
6,179,555
Members
452,928
Latest member
101blockchains

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top