Macro to combine start and end dates of resoucres into one line

[latkan]

<tbody>
[TD="class: votecell"][/TD]
[TD="class: postcell"] I work with a resourcing ledger which is also used for other financial purposes. As a result of the financial phases each resource in the file is split over 4-5 rows. What I would like to do is create a macro which finds their start date and corresponding end date on the next few rows and combines them whilst deleting the other rows and dates in between which show the interim date.


Another twist is that the file also holds roles yet to be fulfilled and are therefore just simply TBC.


I also need to do the same for the TBCs but instead will use the name of the role rather than the resource name to do the deletion of in between dates I have no idea how to go about this

So far I have created the following macros which goes through the dates and as long as they are in ldest to newest order - will seek out the lines which follow on from the original line. It does not however combine the start and final end date

Sub LoopRange3()

'Start at the currently selected cell
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 1).Value <> ""
'Inside loop
Do While Cells(y, 1).Value <> ""
'Test for duplication:
'If the values of the third column (C) and the fifth column (E) match in two rows
'delete the second row of the pair, otherwise go to the next row until the end
If (Cells(x, 3).Value = Cells(y, 3).Value) _
And (Cells(x, 5).Value = Cells(y, 5).Value) _
And (Cells(x, 7).Value = Cells(y, 7).Value) _
And (Cells(x, 9).Value = Cells(y, 9).Value) _
And (Cells(x, 10).Value = Cells(y, 10).Value) _
And (Cells(x, 13).Value <> Cells(y, 13).Value) _
And (Cells(y, 13).Value >= Cells(x, 14).Value) _
Then

'FOR DUPLICATE DELETION: Uncommment the following line by removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line a comment by adding an apostrophe
Cells(y, 3).EntireRow.Interior.ColorIndex = 3

Else

'FOR DUPLICATE DELETION: Uncomment the following line by removing the apostrophe

End If

'FOR DUPLICATE DELETION: Make the following line a comment by adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting point to the next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub






any help would be great

[/TD]

</tbody>

 

[hiker95]

latkan,

Is the macro picking up the correct data/values for the cells colored BLUE, VIOLET, light GREEN?????

Please respond:
1. Is cell O13 the correct value from F13 or F14?
2. Is cell O15 the correct value from F15 or F16 or F17?
3. Is cell O18 the correct value from F18 or F19 or F20?

Excel 2007
	F	G	H	K	L	M	N	O	P	Q	T	U	V
2	Unique ID	Project Role Name	Full Name	Status	Start Date	End Date		Results
3	1.0	Marketing Analyst	Jane Austen	Active	1-Nov-13	4-Jan-14		1.0	Marketing Analyst	Jane Austen	Active	1-Nov-13	29-Sep-14
4	45.0	Marketing Analyst	Jane Austen	Scheduled	5-Jan-14	31-May-14
5	1334.0	Marketing Analyst	Jane Austen	Scheduled	1-Jun-14	29-Sep-14
6	649.0	Marketing Analyst	Jim Murray	Active	29-Jun-13	21-Jan-14		649.0	Marketing Analyst	Jim Murray	Active	29-Jun-13	4-Nov-14
7	677.0	Marketing Analyst	Jim Murray	Scheduled	22-Jan-14	4-Nov-14
8	453.0	Marketing Analyst	Joe Bloggs	Active	26-Jul-13	28-Dec-13		453.0	Marketing Analyst	Joe Bloggs	Active	26-Jul-13	1-Feb-14
9	4685.0	Marketing Analyst	Joe Bloggs	Scheduled	28-Dec-13	1-Feb-14
10	33.0	Manager	TBC	Searching	22-Nov-13	1-Feb-14		33.0	Manager	TBC	Searching	22-Nov-13	26-Apr-14
11	3888.0	Manager	TBC	Searching	2-Feb-14	26-Apr-14
12	4098.0	Manager	TBC	Searching	28-Apr-14	30-Aug-14
13	5876.0	Finance Analyst	TBC	Searching	28-Nov-13	30-Sep-14		5432.0	Finance Analyst	TBC	Searching	28-Nov-13	1-Apr-15
14	5432.0	Finance Analyst	TBC	Searching	2-Oct-14	1-Apr-15
15	342.0	Offshore HR	TBC	Searching	3-Feb-14	13-Feb-15		342.0	Offshore HR	TBC	Searching	1-Jan-14	13-Feb-15
16	123.0	Offshore HR	TBC	Searching	6-Jan-14	13-Feb-15
17	321.0	Offshore HR	TBC	Searching	1-Jan-14	30-Nov-14
18	5461.0	Data Analyser	TBC	Searching	4-Nov-13	13-Apr-15		3333.0	Data Analyser	TBC	Searching	4-Nov-13	13-Sep-15
19	3333.0	Data Analyser	TBC	Searching	14-Apr-15	13-Sep-15
20	1111.0	Data Analyser	TBC	Searching	4-Nov-13	13-Feb-15
Sheet1

 

[latkan]

latkan,

Is the macro picking up the correct data/values for the cells colored BLUE, VIOLET, light GREEN?????

Please respond:
1. Is cell O13 the correct value from F13 or F14?
2. Is cell O15 the correct value from F15 or F16 or F17?
3. Is cell O18 the correct value from F18 or F19 or F20?

Hi Hiker,

Yes I can confirm that the macro is picking up the correct cells

would I be able to get a copy of the macro file?

Thanks!

 

[hiker95]

latkan,

Sample raw data:

Excel 2007
	F	G	H	I	J	K	L	M
2	Unique ID	Project Role Name	Full Name	Division	Sub Division	Status	Start Date	End Date
3	1.0	Marketing Analyst	Jane Austen	Finance	Ledger	Active	1-Nov-13	4-Jan-14
4	45.0	Marketing Analyst	Jane Austen	Finance	Ledger	Scheduled	5-Jan-14	31-May-14
5	1334.0	Marketing Analyst	Jane Austen	Finance	Ledger	Scheduled	1-Jun-14	29-Sep-14
6	649.0	Marketing Analyst	Jim Murray	HR	Customer Care	Active	29-Jun-13	21-Jan-14
7	677.0	Marketing Analyst	Jim Murray	HR	Customer Care	Scheduled	22-Jan-14	4-Nov-14
8	453.0	Marketing Analyst	Joe Bloggs	Marketing	Sales	Active	26-Jul-13	28-Dec-13
9	4685.0	Marketing Analyst	Joe Bloggs	Marketing	Sales	Scheduled	28-Dec-13	1-Feb-14
10	33.0	Manager	TBC	Merchandising	Shop Retail	Searching	22-Nov-13	1-Feb-14
11	3888.0	Manager	TBC	Merchandising	Shop Retail	Searching	2-Feb-14	26-Apr-14
12	4098.0	Manager	TBC	Merchandising	Shop Retail	Searching	28-Apr-14	30-Aug-14
13	5876.0	Finance Analyst	TBC	Merchandising	Shop Retail	Searching	28-Nov-13	30-Sep-14
14	5432.0	Finance Analyst	TBC	Merchandising	Shop Retail	Searching	2-Oct-14	1-Apr-15
15	342.0	Offshore HR	TBC	Logistics	Transport	Searching	3-Feb-14	13-Feb-15
16	123.0	Offshore HR	TBC	Logistics	Transport	Searching	6-Jan-14	13-Feb-15
17	321.0	Offshore HR	TBC	Logistics	Transport	Searching	1-Jan-14	30-Nov-14
18	5461.0	Data Analyser	TBC	Legal	Contracts	Searching	4-Nov-13	13-Apr-15
19	3333.0	Data Analyser	TBC	Legal	Contracts	Searching	14-Apr-15	13-Sep-15
20	1111.0	Data Analyser	TBC	Legal	Contracts	Searching	4-Nov-13	13-Feb-15
21
Sheet1

After the macro (with the results to the right of the raw data):

Excel 2007
	N	O	P	Q	R	S	T	U	V	W
2			Unique ID	Project Role Name	Full Name	Division	Sub Division	Status	Start Date	End Date
3			1.0	Marketing Analyst	Jane Austen	Finance	Ledger	Active	1-Nov-13	29-Sep-14
4			649.0	Marketing Analyst	Jim Murray	HR	Customer Care	Active	29-Jun-13	4-Nov-14
5			453.0	Marketing Analyst	Joe Bloggs	Marketing	Sales	Active	26-Jul-13	1-Feb-14
6			33.0	Manager	TBC	Merchandising	Shop Retail	Searching	22-Nov-13	30-Aug-14
7			5876.0	Finance Analyst	TBC	Merchandising	Shop Retail	Searching	28-Nov-13	1-Apr-15
8			342.0	Offshore HR	TBC	Logistics	Transport	Searching	1-Jan-14	13-Feb-15
9			5461.0	Data Analyser	TBC	Legal	Contracts	Searching	4-Nov-13	13-Sep-15
10
11
12
13
14
15
16
17
18
19
20
21
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub GetUniqueShortList()
' hiker95, 11/19/2013
' http://www.mrexcel.com/forum/excel-questions/737912-macro-combine-start-end-dates-resoucres-into-one-line.html
Dim o As Variant, no As Variant, i As Long, c As Long
Dim r As Long, lrf As Long, lr As Long, n As Long, rng As Range, rngL As Range, rngM As Range
Dim LDate As Date, MDate As Date
Application.ScreenUpdating = False
Columns("P:W").ClearContents
lrf = Cells(Rows.Count, "F").End(xlUp).Row
no = Range("N2:O" & lrf)
Range("N2:O" & lrf).ClearContents
Range("N2") = "N"
With Range("N3:N" & lrf)
  .FormulaR1C1 = "=RC[-7]&RC[-6]"
  .Value = .Value
End With
Range("N2:N" & lrf).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("O2:O" & lrf), Unique:=True
n = Application.CountA(Range("O3:O" & lrf))
ReDim o(1 To n, 1 To 8)
Range("O2:O" & lrf).ClearContents
For r = 3 To lrf
  n = Application.CountIf(Columns(14), Cells(r, 14).Value)
  If n = 1 Then
    i = i + 1
    For c = 6 To 13 Step 1
      o(i, c - 5) = Cells(r, c)
    Next c
  ElseIf n > 1 Then
    LDate = WorksheetFunction.Min(Range("L" & r & ":L" & r + n - 1))
    MDate = WorksheetFunction.Max(Range("M" & r & ":M" & r + n - 1))
    i = i + 1
    For c = 6 To 11 Step 1
      o(i, c - 5) = Cells(r, c)
    Next c
    o(i, 7) = LDate
    o(i, 8) = MDate
  End If
  r = r + n - 1
Next r
Range("N2:O" & lrf) = no
With Range("P2").Resize(, 8)
  .Value = Range("F2").Resize(, 8).Value
  .Font.Bold = True
  .HorizontalAlignment = xlCenter
End With
Range("P3").Resize(UBound(o, 1), UBound(o, 2)) = o
With Range("P3:P" & lrf)
  .NumberFormat = "0.0"
  .HorizontalAlignment = xlCenter
End With
With Range("V3:W" & lrf)
  .NumberFormat = "d-mmm-yy"
End With
Columns("P:W").AutoFit
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the GetUniqueShortList macro.


1. Do you want the results to replace the raw data?

2. Do you want the results to be on a new worksheet?

 

[latkan]

Hi Hiker,

Thanks, the raw data to the side is fine, if not better as it allows easy reference.

However I have spoken to my lead and the resourcing file has thrown a curve ball to me in two manners

1. There will be some people working 50% on one task and 50% on another task
2. The people may "progress" in their development and move into different role or be in the same role but in a different country work location but still the same person will need to be recorded

I do have a employee number per person which I can add to the file and I think this could be used to drive the macro. I have attached the file again with the extra raw data information required

Would you be able to help on this. the macros works well up to a certain extent which is annoying as its so close with the end product.

Apologies for being very needy in this case

 

[latkan]

Also another aspect is that when they do move onto different roles they may start the role at a later date e.g. if they finish in Dec 28th, they will naturally be pencilled in for the start of the new year but after office shut down so in this case 4th Jan 2014. Will the macro pick this 5-7 day grace?

 

[latkan]

https://app.box.com/s/f9zzu516v48a3filpp42

above is the link to the new file

 

[hiker95]

latkan,

I can see the logic for the current task.

You have two choices:

1. The MrExcel.com team can provide consulting services for all of the applications in the Microsoft Office Suite!
Excel Consultant | Excel Consulting | Microsoft Office Consultants

2. Click on the Reply to Thread button, and just put the word BUMP in the post. Then, click on the Post Quick Reply button, and someone else will assist you.