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

sharack

New Member
Joined
Oct 31, 2022
Messages
2
Office Version
  1. 365
Platform
  1. Windows
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
ABCD
1SprintLocationSP
2Sprint 1Leipzig5
3Sprint 1Speyer 3
4Sprint 1München1
5Sprint 1Leipzig4
6Sprint 1Leipzig5
7Sprint 2München1
8
9
Data


Example VBA.xlsx
AB
1SprintSP
2Sprint 114
3Sprint 2
4Sprint 3
Leipzig


Example VBA.xlsx
AB
1SprintSP
2Sprint 1
3Sprint 2
4Sprint 3
Speyer


Example VBA.xlsx
AB
1SprintSP
2Sprint 1
3Sprint 2
4Sprint 3
München
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Maybe helps you...
1667231772588.png
1667231830152.png


VBA Code:
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
 
Upvote 0
Solution
Maybe helps you...
View attachment 77441 View attachment 77443

VBA Code:
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"?
 
Upvote 0

Forum statistics

Threads
1,223,099
Messages
6,170,107
Members
452,302
Latest member
TaMere

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