create a macro that will replicate the output of my helper columns

[ajm]

G'day folks, an interesting job has been given to me at work. We have a work planning tool that displays all jobs and projects (Work Type) that are ongoing and planned and calculates the human hours (“effort hours”) required to fulfil them based on start and end date. boss then decides whether to bring in temporary labour if we are overrun.

An issue has been identified which i now need to fix. Where we have a planned project, (these are broken down into individual jobs ("project jobs")), the amount of required effort is being duplicated. This is because the effort hours are recorded against the Project line and then also for each project job.

De dupe Forward Plan Hours.xlsx
	A	B	C	D	E	F	G	H
1	Task	End Date	Need	Status	Work Type	Start Date	Work Code	Total Length (Days)
2	Leaks	17-Sep-2023	Yes	OK	Project	09-Mar-2020	Keep Going	1287
3	Leaks	17-Sep-2023	Yes	OK	Job	17-Mar-2021	Keep Going	914
4	Blanket Change	27-Feb-2023	Yes	OK	Job	28-Feb-2018	Keep Going	1825
5	Blanket Change	13-Mar-2028	Yes	OK	Job	14-Mar-2017	Keep Going	4017
6	Blanket Change	23-Jun-2025	Yes	OK	Job	24-Jun-2020	Swap Out	1825
7	Blanket Change	09-Jan-2027	Yes	OK	Job	10-Jan-2022	Swap Out	1825
8	Chemical Supply	30-Apr-2025	Yes	OK	Project	01-May-2020	Swap Out	1825
9	Chemical Supply	30-Apr-2025	Yes	OK	Pricing	01-May-2020	Swap Out	1825
10	Chemical Supply	30-Apr-2025	Yes	OK	Pricing	01-May-2020	Swap Out	1825
11	Chemical Supply	30-Apr-2025	Yes	OK	Pricing	01-May-2020	Swap Out	1825
12	Chemical Supply	30-Apr-2025	Yes	OK	Pricing	01-May-2020	Swap Out	1825
13	Chemical Supply	30-Apr-2025	Yes	OK	Pricing	01-May-2020	Swap Out	1825
Sheet1

So, I have concatenated several fields (Task & Need & Status & Work Type & Work Code & Start Date) and done a countif to identify my unique records. The aim is to identify work items (project or job) that are duplicated, and to remove that work items hours. That’s all simple enough except….

De dupe Forward Plan Hours.xlsx
	J	K	L	M
1	If O&C, Count Descriptions	Concat	Sequence	Duration
2	2	LeaksYesOKProjectKeep Going45186	1	1287
3	2	LeaksYesOKJobKeep Going45186	1	914
4	2	Blanket ChangeYesOKJobKeep Going44984	1	1825
5	2	Blanket ChangeYesOKJobKeep Going46825	1	4017
6	2	Blanket ChangeYesOKJobSwap Out45831	1	1825
7	2	Blanket ChangeYesOKJobSwap Out46396	1	1825
8	8	Chemical SupplyYesOKProjectSwap Out45777	1	1825
9	8	Chemical SupplyYesOKPricingSwap Out45777	1	1825
10	8	Chemical SupplyYesOKPricingSwap Out45777	2
11	8	Chemical SupplyYesOKPricingSwap Out45777	3
12	8	Chemical SupplyYesOKPricingSwap Out45777	4
13	8	Chemical SupplyYesOKPricingSwap Out45777	5
Sheet1

Cell Formulas
Range	Formula
J2:J13	J2	=IF(AND(C2="Yes",D2="OK"),COUNTIFS($A$2:$A$1451,A2,$C$2:$C$1451,C2,$D$2:$D$1451,D2,$G$2:$G$1451,G2),"")
K2:K13	K2	=IF(J2="","",IF(J2>1,A2&C2&D2&E2&G2&B2,""))
L2:L13	L2	=IF(K2="","",COUNTIF($K$2:K2,K2))
M2:M13	M2	=IF(L2=1,H2,"")

Where a Project and a Job have the same end date, the effort is to be recorded against only one of these.

De dupe Forward Plan Hours.xlsx
	K	L	M
8	Chemical SupplyYesOKProjectSwap Out45777	1	1825
9	Chemical SupplyYesOKPricingSwap Out45777	1	1825
Sheet1

Cell Formulas
Range	Formula
K8:K9	K8	=IF(J8="","",IF(J8>1,A8&C8&D8&E8&G8&B8,""))
L8:L9	L8	=IF(K8="","",COUNTIF($K$2:K8,K8))
M8:M9	M8	=IF(L8=1,H8,"")

To get around this, I used the concatenated strings from above, and removed the work type. Then did a countif based on the amended concatenated string to get a single number for effort for the entire project.

De dupe Forward Plan Hours.xlsx
	N	O	P
8	Chemical SupplyYesOKSwap Out45777	1	1825
9	Chemical SupplyYesOKSwap Out45777	2
Sheet1

Cell Formulas
Range	Formula
N8:N9	N8	=IF(M8="","",A8&C8&D8&G8&B8)
O8:O9	O8	=IF(N8="","",COUNTIF($N$2:N8,N8))
P8:P9	P8	=IF(O8=1,M8,"")

While I am ok with these extra helper columns, I would like to add these steps into the a macro. Can someone help me code it?

 

[bebo021999]

code will create a sheet named "OUTPUT" to dupplicate sheet1
Create a button in sheet "Sheet1" and assign below code into:

Option Explicit
Sub project()
Dim lr&, i&, rng, sp, id As String, dic As Object
Set dic = CreateObject("Scripting.Dictionary")

'dupplicate to sheet OUTPUT
If Evaluate("=ISREF(OUTPUT!A1)") Then Sheets("OUTPUT").Delete
Application.CopyObjectsWithCells = False 'do not copy button
Sheets("Sheet1").Copy after:=Sheets("Sheet1")
Application.CopyObjectsWithCells = True
ActiveSheet.Name = "OUTPUT"
'----------
With Sheets("OUTPUT")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:H" & lr).Value2
    For i = 1 To UBound(rng)
        id = rng(i, 1) & "|" & rng(i, 3) & "|" & rng(i, 4) & "|" & rng(i, 7) ' id like "Leaks|Yes|OK|Keepgoing"
        If Not dic.exists(id) And rng(i, 5) = "Project" Then ' if "Project" then add id into dictionary
            dic.Add id, rng(i, 6) & "|" & rng(i, 2)
        End If
    Next
    For i = 1 To UBound(rng)
        id = rng(i, 1) & "|" & rng(i, 3) & "|" & rng(i, 4) & "|" & rng(i, 7)
        If rng(i, 5) <> "Project" And dic.exists(id) Then ' id found in dictionary, but not "Project"
            sp = Split(dic(id), "|")
            If rng(i, 6) >= CDate(sp(0)) And rng(i, 2) <= CDate(sp(1)) Then rng(i, 8) = "" ' if duration is within project date range
        End If
    Next
    .Range("A2").Resize(UBound(rng), UBound(rng, 2)).Value = rng ' paste original data, but delete days column whete Task dupplicate
    .Range("H2:H" & lr).SpecialCells(xlBlanks).EntireRow.Delete ' delete duplicate Tasks. remove this line if you want it to be presented.
End With
End Sub

Book1.xlsm

drive.google.com

 

[ajm]

code will create a sheet named "OUTPUT" to dupplicate sheet1
Create a button in sheet "Sheet1" and assign below code into:

Option Explicit
Sub project()
Dim lr&, i&, rng, sp, id As String, dic As Object
Set dic = CreateObject("Scripting.Dictionary")

'dupplicate to sheet OUTPUT
If Evaluate("=ISREF(OUTPUT!A1)") Then Sheets("OUTPUT").Delete
Application.CopyObjectsWithCells = False 'do not copy button
Sheets("Sheet1").Copy after:=Sheets("Sheet1")
Application.CopyObjectsWithCells = True
ActiveSheet.Name = "OUTPUT"
'----------
With Sheets("OUTPUT")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:H" & lr).Value2
    For i = 1 To UBound(rng)
        id = rng(i, 1) & "|" & rng(i, 3) & "|" & rng(i, 4) & "|" & rng(i, 7) ' id like "Leaks|Yes|OK|Keepgoing"
        If Not dic.exists(id) And rng(i, 5) = "Project" Then ' if "Project" then add id into dictionary
            dic.Add id, rng(i, 6) & "|" & rng(i, 2)
        End If
    Next
    For i = 1 To UBound(rng)
        id = rng(i, 1) & "|" & rng(i, 3) & "|" & rng(i, 4) & "|" & rng(i, 7)
        If rng(i, 5) <> "Project" And dic.exists(id) Then ' id found in dictionary, but not "Project"
            sp = Split(dic(id), "|")
            If rng(i, 6) >= CDate(sp(0)) And rng(i, 2) <= CDate(sp(1)) Then rng(i, 8) = "" ' if duration is within project date range
        End If
    Next
    .Range("A2").Resize(UBound(rng), UBound(rng, 2)).Value = rng ' paste original data, but delete days column whete Task dupplicate
    .Range("H2:H" & lr).SpecialCells(xlBlanks).EntireRow.Delete ' delete duplicate Tasks. remove this line if you want it to be presented.
End With
End Sub

Book1.xlsm

drive.google.com

Bebo, many thanks. i will have a play around with it today. cheers and Happy New Year.