Macro that generates new work sheet with people and tasks they perform

1 Attachment(s)

Hello All,
I have spent many hours on YouTube trying to write a simple macro that would help me with my reports that I have to run and data-manipulate manually every month. I am afraid that this macro exceeds my current knowledge and, as suggested and highly recommended by one of my friends, I am totally dependent on ExcelForum specialists.
What I am looking for is a macro that would generate a separate worksheet and populate all names and tasks people perform. I have attached a spread sheet with my small database example just to give you an idea.
The main source (database) I receive every month is a simple spread sheet containing just several columns:
- Column A - Name of a person
- Column B - Team of that person
- Column C - Task 1 (with "1" if the tasks has been performed at least once or blank if it has not)
- Column D - Task 2 (with "1" if the tasks has been performed at least once or blank if it has not)
- Column E - Task 3 (with "1" if the tasks has been performed at least once or blank if it has not)
Of course some people are involved in more tasks then others and in some months some of them do not perform these identified tasks at all.

What I am looking for is a simple button that would copy all the names into a separate spread sheet that would look like "Result" that I created manually. For every person performing more than one tasks, the macro would populate the name twice, each with different task. If for any reason one of the names has no "1" for any of the tasks, which means none of the three identified tasks have been performed by that person, that person would be skipped. Every month the tasks will be the same but the number of people and tasks they perform may change significantly.
As an extra feature, there could be a radio button that would identify whether all departments or only one of them would be included in the generated tasks list.

If there is anybody who could help me with writing that macro I would be VERY grateful !

I am available any time for additional comments, further explanation and to answer any questions.

I am looking forward to hearing from you soon.

Thank you.

The following code will do what you want for All Departments:

Code:

Sub MakeResult() Dim i As Long, j As Long j = 1 With Sheets("Result").Range("A1") .Offset(0, 0) = "Name" .Offset(0, 1) = "Team" .Offset(0, 2) = "Task" For i = 1 To Sheets("Source").Range("A1").CurrentRegion.Rows.Count - 1 .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = Sheets("Source").Range("A1").Offset(i, 1) If Sheets("Source").Range("A1").Offset(i, 2) = 1 Then .Offset(j, 2) = "Task1" If Sheets("Source").Range("A1").Offset(i, 3) = 1 Then j = j + 1 .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = Sheets("Source").Range("A1").Offset(i, 1) .Offset(j, 2) = "Task2" If Sheets("Source").Range("A1").Offset(i, 4) = 1 Then j = j + 1 .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = Sheets("Source").Range("A1").Offset(i, 1) .Offset(j, 2) = "Task3" End If ElseIf Sheets("Source").Range("A1").Offset(i, 4) = 1 Then j = j + 1 .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = Sheets("Source").Range("A1").Offset(i, 1) .Offset(j, 2) = "Task3" End If ElseIf Sheets("Source").Range("A1").Offset(i, 3) = 1 Then .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = Sheets("Source").Range("A1").Offset(i, 1) .Offset(j, 2) = "Task2" If Sheets("Source").Range("A1").Offset(i, 4) = 1 Then j = j + 1 .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = Sheets("Source").Range("A1").Offset(i, 1) .Offset(j, 2) = "Task3" End If ElseIf Sheets("Source").Range("A1").Offset(i, 4) = 1 Then .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = Sheets("Source").Range("A1").Offset(i, 1) .Offset(j, 2) = "Task3" End If j = j + 1 Next i End With End Sub

If you use ActiveX OptionButtons with the names OptAllDepartments, OptInternational and OptDomestic, then the following code will populate the Results sheet with the relevant records from the Source sheet for the OptionButton that is selected:

Code:

Sub MakeResult() Dim i As Long, j As Long Dim strTeam As String If Sheets("Source").OptAllDepartments.Value = True Then strTeam = "All" ElseIf Sheets("Source").optInternational.Value = True Then strTeam = "International" Else strTeam = "Domestic" End If j = 1 With Sheets("Result").Range("A1") .Offset(0, 0) = "Name" .Offset(0, 1) = "Team" .Offset(0, 2) = "Task" If strTeam = "All" Then For i = 1 To Sheets("Source").Range("A1").CurrentRegion.Rows.Count - 1 .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = Sheets("Source").Range("A1").Offset(i, 1) If Sheets("Source").Range("A1").Offset(i, 2) = 1 Then .Offset(j, 2) = "Task1" If Sheets("Source").Range("A1").Offset(i, 3) = 1 Then j = j + 1 .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = Sheets("Source").Range("A1").Offset(i, 1) .Offset(j, 2) = "Task2" If Sheets("Source").Range("A1").Offset(i, 4) = 1 Then j = j + 1 .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = Sheets("Source").Range("A1").Offset(i, 1) .Offset(j, 2) = "Task3" End If ElseIf Sheets("Source").Range("A1").Offset(i, 4) = 1 Then j = j + 1 .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = Sheets("Source").Range("A1").Offset(i, 1) .Offset(j, 2) = "Task3" End If ElseIf Sheets("Source").Range("A1").Offset(i, 3) = 1 Then .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = Sheets("Source").Range("A1").Offset(i, 1) .Offset(j, 2) = "Task2" If Sheets("Source").Range("A1").Offset(i, 4) = 1 Then j = j + 1 .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = Sheets("Source").Range("A1").Offset(i, 1) .Offset(j, 2) = "Task3" End If ElseIf Sheets("Source").Range("A1").Offset(i, 4) = 1 Then .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = Sheets("Source").Range("A1").Offset(i, 1) .Offset(j, 2) = "Task3" End If j = j + 1 Next i ElseIf strTeam = "International" Then For i = 1 To Sheets("Source").Range("A1").CurrentRegion.Rows.Count - 1 If Sheets("Source").Range("A1").Offset(i, 1) = "International" Then .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = "International" If Sheets("Source").Range("A1").Offset(i, 2) = 1 Then .Offset(j, 2) = "Task1" If Sheets("Source").Range("A1").Offset(i, 3) = 1 Then j = j + 1 .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = "International" .Offset(j, 2) = "Task2" If Sheets("Source").Range("A1").Offset(i, 4) = 1 Then j = j + 1 .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = "International" .Offset(j, 2) = "Task3" End If ElseIf Sheets("Source").Range("A1").Offset(i, 4) = 1 Then j = j + 1 .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = "International" .Offset(j, 2) = "Task3" End If ElseIf Sheets("Source").Range("A1").Offset(i, 3) = 1 Then .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = "International" .Offset(j, 2) = "Task2" If Sheets("Source").Range("A1").Offset(i, 4) = 1 Then j = j + 1 .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = "International" .Offset(j, 2) = "Task3" End If ElseIf Sheets("Source").Range("A1").Offset(i, 4) = 1 Then .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = "International" .Offset(j, 2) = "Task3" End If j = j + 1 End If Next i Else For i = 1 To Sheets("Source").Range("A1").CurrentRegion.Rows.Count - 1 If Sheets("Source").Range("A1").Offset(i, 1) = "Domestic" Then .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = "International" If Sheets("Source").Range("A1").Offset(i, 2) = 1 Then .Offset(j, 2) = "Task1" If Sheets("Source").Range("A1").Offset(i, 3) = 1 Then j = j + 1 .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = "Domestic" .Offset(j, 2) = "Task2" If Sheets("Source").Range("A1").Offset(i, 4) = 1 Then j = j + 1 .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = "Domestic" .Offset(j, 2) = "Task3" End If ElseIf Sheets("Source").Range("A1").Offset(i, 4) = 1 Then j = j + 1 .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = "Domestic" .Offset(j, 2) = "Task3" End If ElseIf Sheets("Source").Range("A1").Offset(i, 3) = 1 Then .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = "Domestic" .Offset(j, 2) = "Task2" If Sheets("Source").Range("A1").Offset(i, 4) = 1 Then j = j + 1 .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = "Domestic" .Offset(j, 2) = "Task3" End If ElseIf Sheets("Source").Range("A1").Offset(i, 4) = 1 Then .Offset(j, 0) = Sheets("Source").Range("A1").Offset(i, 0) .Offset(j, 1) = "Domestic" .Offset(j, 2) = "Task3" End If j = j + 1 End If Next i End If End With End Sub

Doug,I have tried your code and it works perfectly. Thank you very much for your quick response.

Doug,there is one more think. In the oroginal file there are three tasks however potentially there should be many more.Eventually, I will be having not 3 but 11 tasks. I tried to add no. 4 and for me it seems impossible to implement no 4. Amending the cody to include 11 tasks seems completely impossible.Would you recomend any other solution, please?I would be very grateful for any help.Thank you.

FYI:
http://www.excelforum.com/excel-prog...y-perform.html

This might suffice:

Code:

Sub M_snb() sn = Sheets("source").Cells(1).CurrentRegion ReDim sp((UBound(sn) - 1) * (UBound(sn, 2) - 2), 2) For j = 0 To UBound(sp) - 1 If sn(2 + j \ (UBound(sp, 2) + 1), 3 + j Mod (UBound(sp, 2) + 1)) <> "" Then For jj = 0 To UBound(sp, 2) sp(j, jj) = sn(IIf(jj = UBound(sp, 2), 1, 2 + j \ (UBound(sp, 2) + 1)), IIf(jj = UBound(sp, 2), 3 + j Mod (UBound(sp, 2) + 1), 1 + jj Mod (UBound(sp, 2)))) Next End If Next Sheets("result").Cells(1).Resize(UBound(sp) + 1, UBound(sp, 2) + 1) = sp Sheets("result").Columns(1).SpecialCells(4).EntireRow.Delete End Sub

The following macros will handle any number of tasks, the first one for all teams and the second for the team for which the ActiveX Option button is selected:

Code:

Sub MakeResultAll() Dim arrData As Variant Dim i As Long, j As Long, k As Long Dim strName As String, strTeam As String, strTask As String k = 1 arrData = Sheets("Source").Range("A1").CurrentRegion With Sheets("Result").Range("A1") .Offset(0, 0) = "Name" .Offset(0, 1) = "Team" .Offset(0, 2) = "Task" For i = 2 To UBound(arrData, 1) strName = arrData(i, 1) strTeam = arrData(i, 2) For j = 3 To UBound(arrData, 2) If arrData(i, j) = 1 Then .Offset(k, 0) = strName .Offset(k, 1) = strTeam .Offset(k, 2) = arrData(1, j) k = k + 1 End If Next j Next i End With End Sub Sub MakeResultforTeam() Dim arrData As Variant Dim i As Long, j As Long, k As Long Dim strName As String, strTeam As String, strTask As String arrData = Sheets("Source").Range("A1").CurrentRegion If Sheets("Source").optAllDepartments.Value = True Then strTeam = "All" ElseIf Sheets("Source").optInternational.Value = True Then strTeam = "International" Else strTeam = "Domestic" End If k = 1 With Sheets("Result").Range("A1") .Offset(0, 0) = "Name" .Offset(0, 1) = "Team" .Offset(0, 2) = "Task" If strTeam = "All" Then For i = 2 To UBound(arrData, 1) strName = arrData(i, 1) strTeam = arrData(i, 2) For j = 3 To UBound(arrData, 2) If arrData(i, j) = 1 Then .Offset(k, 0) = strName .Offset(k, 1) = strTeam .Offset(k, 2) = arrData(1, j) k = k + 1 End If Next j Next i ElseIf strTeam = "International" Then For i = 2 To UBound(arrData, 1) If arrData(i, 2) = strTeam Then strName = arrData(i, 1) For j = 3 To UBound(arrData, 2) If arrData(i, j) = 1 Then .Offset(k, 0) = strName .Offset(k, 1) = strTeam .Offset(k, 2) = arrData(1, j) k = k + 1 End If Next j End If Next i Else strTeam = "Domestic" For i = 2 To UBound(arrData, 1) If arrData(i, 2) = strTeam Then strName = arrData(i, 1) For j = 3 To UBound(arrData, 2) If arrData(i, j) = 1 Then .Offset(k, 0) = strName .Offset(k, 1) = strTeam .Offset(k, 2) = arrData(1, j) k = k + 1 End If Next j End If Next i End If End With End Sub