VBA: Copy values which met condition, add them up and copy them to other sheet

[sharack]

Hello guys,
i need your kind help with a topic:
I have a list of SPs for locations in my "Data" Sheet. Furthermore i have sheets for the specific locations.
What i want to do is to create a macro which filters the "Data" sheet to copy the SPs in column C which have the same location in column B. These values of one location should then be added up and copied to the location sheet for the respective sprint.

So if i take Leipzig on "Data" sheet i would have for Sprint 1 14 Points. This value should then be copied to "Leipzig" sheet to cell in column B (SP) where cell in column A in the same row should contain "Sprint 1".
I want to do this every month so also for Sprint 2, 3 etc which i will then insert to "Data" sheet.

Would be great if you could help me because i have never used VBA before. Thank you so much for your effort!

Example VBA.xlsx
	A	B	C	D
1	Sprint	Location	SP
2	Sprint 1	Leipzig	5
3	Sprint 1	Speyer	3
4	Sprint 1	München	1
5	Sprint 1	Leipzig	4
6	Sprint 1	Leipzig	5
7	Sprint 2	München	1
8
9
Data

Example VBA.xlsx
	A	B
1	Sprint	SP
2	Sprint 1	14
3	Sprint 2
4	Sprint 3
Leipzig

Example VBA.xlsx
	A	B
1	Sprint	SP
2	Sprint 1
3	Sprint 2
4	Sprint 3
Speyer

Example VBA.xlsx
	A	B
1	Sprint	SP
2	Sprint 1
3	Sprint 2
4	Sprint 3
München

 

[Flaiban]

Maybe helps you...

Sub SprintSum()
Dim sSh As Worksheet, dSh As Worksheet
Dim dNext As Long, I As Long, J As Long, wArr, oArr()
Dim myDic As Object, myK As String, NextO As Long
'
Set sSh = Sheets("Data")         '<<< The sheet with the starting info
Set dSh = Sheets("Sheet2")         '<<< The sheet where the summary will be created. Insert the same headers of spreadsheet Data
'
wArr = sSh.Range("A1").CurrentRegion.Value
    ReDim oArr(1 To UBound(wArr), 1 To UBound(wArr, 2))
    Set myDic = CreateObject("Scripting.Dictionary")
    dSh.Range("A1").CurrentRegion.ClearContents             '!!! Clear the output area
NextO = 1
For I = 1 To UBound(wArr)
    myK = wArr(I, 1) & "#" & wArr(I, 2)
    If myDic.Exists(myK) Then
        oArr(myDic.Item(myK), 3) = oArr(myDic.Item(myK), 3) + wArr(I, 3)
        oArr(myDic.Item(myK), 2) = wArr(I, 2)
    Else
        myDic.Add (myK), NextO
        For J = 1 To UBound(wArr, 2)
            oArr(NextO, J) = wArr(I, J)
        Next J
        NextO = NextO + 1
    End If
Next I
dSh.Range("A1").Resize(NextO, UBound(oArr, 2)).Value = oArr
ReDim oArr(1, 1)
End Sub

 

[sharack]

Maybe helps you...
View attachment 77441 View attachment 77443

Sub SprintSum()
Dim sSh As Worksheet, dSh As Worksheet
Dim dNext As Long, I As Long, J As Long, wArr, oArr()
Dim myDic As Object, myK As String, NextO As Long
'
Set sSh = Sheets("Data")         '<<< The sheet with the starting info
Set dSh = Sheets("Sheet2")         '<<< The sheet where the summary will be created. Insert the same headers of spreadsheet Data
'
wArr = sSh.Range("A1").CurrentRegion.Value
    ReDim oArr(1 To UBound(wArr), 1 To UBound(wArr, 2))
    Set myDic = CreateObject("Scripting.Dictionary")
    dSh.Range("A1").CurrentRegion.ClearContents             '!!! Clear the output area
NextO = 1
For I = 1 To UBound(wArr)
    myK = wArr(I, 1) & "#" & wArr(I, 2)
    If myDic.Exists(myK) Then
        oArr(myDic.Item(myK), 3) = oArr(myDic.Item(myK), 3) + wArr(I, 3)
        oArr(myDic.Item(myK), 2) = wArr(I, 2)
    Else
        myDic.Add (myK), NextO
        For J = 1 To UBound(wArr, 2)
            oArr(NextO, J) = wArr(I, J)
        Next J
        NextO = NextO + 1
    End If
Next I
dSh.Range("A1").Resize(NextO, UBound(oArr, 2)).Value = oArr
ReDim oArr(1, 1)
End Sub

Hello,
that helped, thank you . Is it possible to change code that only the data of one city is copied meaning that only data of Leipzig is copied to sheet "Leipzig"?