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

[afniz]

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.

[Doug Robbins]

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


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:


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

[afniz]

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

[afniz]

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.

[p45cal]

FYI:
http://www.excelforum.com/excel-programming-vba-macros/946480-macro-that-generates-new-work-sheet-with-people-and-tasks-they-perform.html

[snb]

This might suffice:


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

[Doug Robbins]

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:


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