VBA: Insert value based on condition in other cell

C

Corne89

New Member
Joined
Apr 21, 2021
Messages
15
Office Version
  1. 2016
Platform
  1. Windows
VBA Jira Auswertung.xlsm
AB
1NameStorypoints
2Sprint 0810
3Sprint 0820
4
5
Tabelle1


VBA Jira Auswertung.xlsm
ABCDEFGHI
1NameStorypointsKosten
2Sprint 050
3Sprint 060
4Sprint 070
5Sprint 080
6
7
8
Auswertung
Cell Formulas
RangeFormula
C2:C5C2=B2*81


Hello guys,
i have a question regarding VBA. I want to, based on my finding from my macro, copy the sum of the storypoints of the sprint from sheet "Tabelle1" to sheet "Auswertung". Thus in my example, if something is found for Sprint 08, and the sum is calculated, this sum for Sprint 08 should be copied to sheet "Auswertung" (Thus sum=30 should be copied) to the cell in column B where cell in A has name "Sprint 08". THerefore in cell B5 the sum should be entered, because A5 has "Sprint 08".

However I didn't figure it out yet how to write that in VBA. Could you please help me out here?
Thank you!

Below you can also find my current VBA code:


Private Sub CommandButton2_Click()
'Read Value from Textbox
TxTbx = TextBox1.Text
'Value from Textbox is stored in cell
Worksheets("Auswertung").Range("Z4").Value = Me.TextBox1
Tabelle1.Select


'Check if Textbox Value is found on other sheet
'Declare Variables
Dim sumRange As Range
Dim Fund As Range
Dim criteriaRange As Range
Dim criteria As String
Set sumRange = Range("B2:B11")
Set criteriaRange = Range("A2:A11")

criteria = Worksheets("Auswertung").Range("Z4").Value
Sheets("Tabelle1").Select

Set Fund = Range("A:A").Find(Worksheets("Auswertung").Range("Z4"))
If Not Fund Is Nothing Then
'Save SumIfs Value in Cell
Range("J4") = WorksheetFunction.SumIfs(sumRange, criteriaRange, criteria)
Range("J4").Copy

Else
MsgBox Prompt:="Ihr Suchbegriff " & Sheets("Auswertung").Range("Z4") & " existiert nicht im Sheet Tabelle1. Bitte prüfen Sie Ihre Eingabe!"
Sheets("Tabelle1").Range("J4").ClearContents



End If





'Range("J4").ClearContents
'Worksheets("Auswertung").Range("Z4").ClearContents

'Closing of UserForm
Unload Sprinteingabe
End Sub
 
Sort by date Sort by votes
Hello,
we thought we adapt our Excel with another criteria, thus not only the "Sprint" but also the "Epic Link" criteria from Jira to get a better overview:

VBA Jira mit Richtiger File v1.xlsm
ABC
1SprintStory PointsEpic Link
2PHI Sprint 01 20236CC 3
3PHI Sprint 01 202316CC 3
4PHI Sprint 01 2023CC 1
5PHI Sprint 01 202340CC 1
6PHI Sprint 01 202320CC 1
7PHI Sprint 01 20238CC 1
8PHI Sprint 01 20236CC 1
9PHI Sprint 01 202318CC 1
10PHI Sprint 01 202310CC 6
Source


This is the new destination sheet:
VBA Jira mit Richtiger File v1.xlsm
ABCDEFG
1Epic Link
2CC1CC 2CC 3CC 4CC 5CC 6
3PHI Sprint 7 2022
4PHI Sprint 8 2022
5PHI Sprint 9 2022
6PHI Sprint 10 2022
7PHI Sprint 11 2022
8PHI Sprint 12 2022
9PHI Sprint 13 2022
10PHI Sprint 01 2023
Destination


Thus, if i use my textbox again, is it possible to search for the sprint name, sum up the storypoints and enter them where the epic link from "Source" matches epic link from "Destination"?
It should look like that, e.g. using "PHI Sprint 01 2023" as search criteria:

VBA Jira mit Richtiger File v1.xlsm
ABCDEFG
1Epic Link
2CC1CC 2CC 3CC 4CC 5CC 6
3PHI Sprint 7 2022
4PHI Sprint 8 2022
5PHI Sprint 9 2022
6PHI Sprint 10 2022
7PHI Sprint 11 2022
8PHI Sprint 12 2022
9PHI Sprint 13 2022
10PHI Sprint 01 2023922210
Destination


I think one can use function =SUMIFS(Source!B2:B10;Source!A2:A10;Destination!A10;Source!C2:C10;Destination!B2) ->Destination B10 but i dont know how to implement this in VBA.

Could you please help me one more time? Thank you! :)
 
Upvote 0

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Try:
VBA Code: 
Private Sub CommandButton2_Click()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, total As Long, x As Long, srcRng As Range, e As Variant, dic As Object, fnd As Range
    Set srcWS = Sheets("Source")
    Set desWS = Sheets("Destination")
    If Not IsError(Application.Match(Me.TextBox1.Value, srcWS.Range("A:A"), 0)) Then
        x = Application.Match(Me.TextBox1.Value, desWS.Range("A:A"), 0)
        With srcWS
            .Range("A1").CurrentRegion.AutoFilter 1, Me.TextBox1.Value
            Set srcRng = .Range("C2", .Range("C" & Rows.Count).End(xlUp))
            Set dic = CreateObject("Scripting.Dictionary")
            For Each e In srcRng
                Set fnd = desWS.Rows(2).Find(e, LookIn:=xlValues, lookat:=xlWhole)
                If Not fnd Is Nothing Then
                    If Not dic.exists(CStr(e)) Then
                        dic.Add CStr(e), Nothing
                        .Range("A1").CurrentRegion.AutoFilter 3, CStr(e)
                        total = WorksheetFunction.Sum(.Range("B2", .Range("B" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible))
                        desWS.Cells(x, fnd.Column) = total
                    End If
                End If
            Next e
        End With
    Else
        MsgBox ("Ihr Suchbegriff " & Me.TextBox1.Value & " existiert nicht im Sheet Tabelle1. Bitte prüfen Sie Ihre Eingabe!")
    End If
    srcWS.Range("A1").AutoFilter
    Unload Me
    Application.ScreenUpdating = True
End Sub
In your Destination sheet, change "CC1" to CC 1" to include the space before trying the macro.
 
Upvote 0
mumps said:
Try:
VBA Code: 
Private Sub CommandButton2_Click()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, total As Long, x As Long, srcRng As Range, e As Variant, dic As Object, fnd As Range
    Set srcWS = Sheets("Source")
    Set desWS = Sheets("Destination")
    If Not IsError(Application.Match(Me.TextBox1.Value, srcWS.Range("A:A"), 0)) Then
        x = Application.Match(Me.TextBox1.Value, desWS.Range("A:A"), 0)
        With srcWS
            .Range("A1").CurrentRegion.AutoFilter 1, Me.TextBox1.Value
            Set srcRng = .Range("C2", .Range("C" & Rows.Count).End(xlUp))
            Set dic = CreateObject("Scripting.Dictionary")
            For Each e In srcRng
                Set fnd = desWS.Rows(2).Find(e, LookIn:=xlValues, lookat:=xlWhole)
                If Not fnd Is Nothing Then
                    If Not dic.exists(CStr(e)) Then
                        dic.Add CStr(e), Nothing
                        .Range("A1").CurrentRegion.AutoFilter 3, CStr(e)
                        total = WorksheetFunction.Sum(.Range("B2", .Range("B" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible))
                        desWS.Cells(x, fnd.Column) = total
                    End If
                End If
            Next e
        End With
    Else
        MsgBox ("Ihr Suchbegriff " & Me.TextBox1.Value & " existiert nicht im Sheet Tabelle1. Bitte prüfen Sie Ihre Eingabe!")
    End If
    srcWS.Range("A1").AutoFilter
    Unload Me
    Application.ScreenUpdating = True
End Sub
In your Destination sheet, change "CC1" to CC 1" to include the space before trying the macro.
Click to expand...
Thank you very much! This worked again. Really appreciate your help! :)
 
Upvote 0
You must log in or register to reply here.

Similar threads

ExcelNewbie2020
  • Solved
VBA to replicate values to allign with the longest non empty cell in other columns
Replies
1
Views
197
Eric W
Eric W
Q
  • Question Question
Automatically insert new rows with predefined values
Replies
1
Views
729
quattroformatee
Q
E
  • Solved
Quick VBA code to Hide Rows based on Cell Value
Replies
3
Views
412
Joe4
Joe4
T
  • Question Question
Open CSV with VBA, convert to ANSI and a cell "75 %" is changed to format type percent and the value is changed to "0.75"
Replies
1
Views
292
Tanquen
T
J
  • Question Question
Automatically move cells from one sheet to another based on criteria using VBA
Replies
5
Views
700
DanteAmor
DanteAmor

Forum statistics

Threads
1,223,098
Messages
6,170,103
Members
452,302
Latest member
TaMere

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