VBA to copy unique data to another workbook w/ tab names

[msquared99]

Here is the situation. I have a report that I run we will call "Report". I have a macro that opens the report once it is saved in its file location. The macro opens up a template called "Master Template". The "Master Template" spreadsheet has four tabs named Team 1, Team 2, Team 3 and, Team 4. Column B of the "Report" contains the names Team 1, Team 2, Team 3 and, Team 4.


My question is how do I change the macro (which works fine) below to copy all specific items named "Team X" from the "Report" into the matched tab name in the "Master Template"?

[pre]

Sub SplitData()
Dim DataMarkers(), Names As Range, name As Range, n As Long, i As Long

'Find unique names
Set Names = Range("B2:B" & Range("B1").End(xlDown).Row)
n = 0

'Add worksheet for each unique name
For Each name In Names
If name.Offset(1, 0) <> name Then
ReDim Preserve DataMarkers(n)
DataMarkers(n) = name.Row
Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = name
n = n + 1
End If
Next name

'Copy the unique data
For i = 0 To UBound(DataMarkers)
If i = 0 Then
Worksheets(1).Range("A2:Y" & DataMarkers(i)).Copy Destination:=Worksheets(i + 2).Range("A1")
Else
Worksheets(1).Range("A" & (DataMarkers(i - 1) + 1) & ":Y" & DataMarkers(i)).Copy Destination:=Worksheets(i + 2).Range("A1")
End If
Next i
End Sub

Here is the macro that opens the "Master Template".


Sub ChooseFile()

Dim fd As FileDialog
Dim FileName As String
Dim lastRow1 As Long ‘for use later
Dim lastRow2 As Long ‘for use later
Dim lastRow3 As Long ‘for use later
Dim lastRow4 As Long ‘for use later

Set fd = Application.FileDialog(msoFileDialogFilePicker)

'Get the number the button chosen.
Dim FileChosen As Integer

FileChosen = fd.Show

If FileChosen <> -1 Then

'Didn't choose anything (clicked cancel).
MsgBox "No file opened."

Exit Sub

Else

'Display name and path of file chosen.
FileName = fd.SelectedItems(1)
Workbooks.Open (FileName)
FileName = Mid(FileName, InStrRev(FileName, "") + 1, Len(FileName))

End Sub

[/pre]
Thanks for any help.

 

[msquared99]

I seem to be on my own here so I have been trying.


The below code works but it copies all the data from FileName instead of just "Team 2" to the "Team 2" tab of the Sample Template.


At least it is some progress.


-----

[pre]

Workbooks(Filename).Activate

Set Rng1 = Range([B1], Range("B" & Rows.Count).End(xlUp))
arCrits1 = Array("Team 2")

For l = o To UBound(arCrits1)
On Error Resume Next
With Rng1
.AutoFilter , field:=2, Criteria1:=arCrits1(l)
.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Workbooks("Sample Template.xlsx").Sheets("Team 2").Range("A" & Rows.Count).End(xlUp).Offset(1)
.AutoFilter
End With
On Error GoTo 0
Next l

Set Rng2 = Range([B1], Range("B" & Rows.Count).End(xlUp))
arCrits2 = Array("Team 3")

For m = o To UBound(arCrits2)
On Error Resume Next
With Rng2
.AutoFilter , field:=2, Criteria1:=arCrits2(m)
.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Workbooks("Sample Template.xlsx").Sheets("Team 3").Range("A" & Rows.Count).End(xlUp).Offset(1)
.AutoFilter
End With
On Error GoTo 0
Next m

[/pre]
-----


EDIT: just for indenting, there were apostrophes instead of backticks (SirJB7)

 

[msquared99]

Persistency has paid off. I finally was able to accomplish my task.

 

[SirJB7]

Hi, msquared99!

Would you be as kind as to post the latest version with the full solution so as people who read this may have the answer too? Thank you.

Regards!