Making a new worksheet for every unique name on a list but I need the worksheet to be a copy of a template

[swoldu]

I am a novice when it comes to making macros so I am in desperate need of help. I have two worksheets, one with data that will be updated with new data everyday and the other, a template that the data needs to fill in by each row accordingly. However the template needs to be a copy of the unique name from column A and renamed by that name. If the template worksheet already exist it will take the information from that matching name and copy certain information to the template. If there is no worksheet(template) existent then it will create a new worksheet according to that unique value from column "A".
The data in worksheet(data) will first need to be filtered by two types, "Redemption" and "Full Liquidation" from column "I" before it can start transferring data.
From worksheet(data) to worksheet(template),
column "A" will be the new worksheet(template) name,
column "E" will be put in Worksheet(template) column "A" starting with row 4,
column "F" will be in column "B",
column "B" will be in column "C",
column "O" will be in column "D",
column "L" will be in column "T".
So far I have this as a Macro, but it does not copy the template and it takes the whole row instead of the specific columns that I need.

Sub PagesByDescription()
Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String
Set wSheetStart = ActiveSheet
wSheetStart.AutoFilterMode = False
'Set a range variable to the correct item column
Set rRange = Range("A1", Range("A65536").End(xlUp))

'Add a sheet called "UniqueList"
Worksheets.Add().Name = "UniqueList"

'Filter the Set range so only a unique list is created
With Worksheets("UniqueList")
rRange.AdvancedFilter xlFilterCopy, , _
Worksheets("UniqueList").Range("A1"), True

'Set a range variable to the unique list, less the heading.
Set rRange = .Range("A2", .Range("A65536").End(xlUp))
End With

On Error Resume Next
With wSheetStart
For Each rCell In rRange
strText = rCell
.Range("A1").AutoFilter 1, strText
Worksheets(strText).Delete
'Add a sheet named as content of rCell
Worksheets.Add("CLASS GROUPING ID").Name = strText
'Copy the visible filtered range _
(default of Copy Method) and leave hidden rows
.UsedRange.Copy Destination:=ActiveSheet.Range("A1")
ActiveSheet.Cells.Columns.AutoFit
Next rCell
End With

With wSheetStart
.AutoFilterMode = False
.Activate
End With

On Error GoTo 0
Application.DisplayAlerts = True
End Sub

Please help I'm in desperate need of some guidance

 

[tigeravatar]

swoldu,

Assuming I've understood you correctly, give this a try:

Sub PagesByDescription()
    
    Dim wsData As Worksheet
    Dim wsTemp As Worksheet
    Dim rngFound As Range
    Dim rngNames As Range
    Dim NameCell As Range
    Dim strFirst As String
    Dim strName As String
    Dim strUnqNames As String
    Dim i As Long
    
    Set wsData = Sheets("Data")
    Set wsTemp = Sheets("Template")
    Set rngNames = wsData.Range("A2", wsData.Cells(Rows.Count, "A").End(xlUp))
    
    For Each NameCell In rngNames.Cells
        If InStr(1, "|" & strUnqNames & "|", "|" & NameCell.Text & "|", vbTextCompare) = 0 Then
            strUnqNames = strUnqNames & "|" & NameCell.Text
            Set rngFound = rngNames.Find(NameCell.Text, rngNames.Cells(rngNames.Cells.Count), xlValues, xlWhole)
            If Not rngFound Is Nothing Then
                strFirst = rngFound.Address
                strName = NameCell.Text
                For i = 1 To 7
                    strName = Replace(strName, Mid(":\/?*[]", i, 1), vbNullString)
                Next i
                strName = Trim(Left(WorksheetFunction.Trim(strName), 31))
                If Evaluate("IsRef('" & strName & "'!A1)") = False Then
                    wsTemp.Copy After:=Sheets(Sheets.Count)
                    ActiveSheet.Name = strName
                End If
                With Sheets(strName)
                    Do
                        .Cells(Rows.Count, "A").End(xlUp).Offset(1).Value = wsData.Cells(rngFound.Row, "E").Value
                        .Cells(Rows.Count, "B").End(xlUp).Offset(1).Value = wsData.Cells(rngFound.Row, "F").Value
                        .Cells(Rows.Count, "C").End(xlUp).Offset(1).Value = wsData.Cells(rngFound.Row, "B").Value
                        .Cells(Rows.Count, "D").End(xlUp).Offset(1).Value = wsData.Cells(rngFound.Row, "O").Value
                        .Cells(Rows.Count, "T").End(xlUp).Offset(1).Value = wsData.Cells(rngFound.Row, "L").Value
                        Set rngFound = rngNames.Find(NameCell.Text, rngFound, xlValues, xlWhole)
                    Loop While rngFound.Address <> strFirst
                End With
            End If
        End If
    Next NameCell
    
    Set wsData = Nothing
    Set wsTemp = Nothing
    Set rngFound = Nothing
    Set rngNames = Nothing
    Set NameCell = Nothing
    
End Sub

 

[swoldu]

Thank you for your help. This is great, but I am very new to VBA and I was trying to decipher some of the code you wrote.


For Each NameCell In rngNames.Cells
If InStr(1, "|" & strUnqNames & "|", "|" & NameCell.Text & "|", vbTextCompare) = 0 Then
strUnqNames = strUnqNames & "|" & NameCell.Text
Set rngFound = rngNames.Find(NameCell.Text, rngNames.Cells(rngNames.Cells.Count), xlValues, xlWhole)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
strName = NameCell.Text
For i = 1 To 7
strName = Replace(strName, Mid(":\/?*[]", i, 1), vbNullString

I was trying to figure out the action brought out by this code.
Also
I needed it to filter the "I" column to two types of values before I start exstracting data, Redemption and Full Liquidation.
I was wondering if I would just put this code in after the third Set line?

Sub Macro1()
Sheets("DATA").Select
Selection.AutoFilter
ActiveWindow.SmallScroll ToRight:=4
ActiveSheet.Range("$A$1:$R$418").AutoFilter Field:=9, Criteria1:= _
"=Full Liquidation", Operator:=xlOr, Criteria2:="=Redemption"
End Sub

Also for some reason the names in column E from the "Data" sheet are being put outside of the template range in "template" sheet. On the "template" sheet the blank rows start at 4 and ends at 68, but the data starts importing the data at row 69. How would I aviod this issue? Really appreciate your help.

 

[tigeravatar]

swoldu,

The strUnqNames is the variable used to make sure the code is only being run on unique entries found in rngNames
Once it confirms a unique entry, it converts the text to a legal worksheet name: worksheet names must be 31 or fewer characters in length, and cannot contain : \ / ? * [ or ]
As for the filter, I would just put in an if statement during the Do loop. And to get the data placed properly (instead of starting at row 69), change the Rows.Count during the Do loop to be 68 instead.

Updated code:

Sub PagesByDescription()
    
    Dim wsData As Worksheet
    Dim wsTemp As Worksheet
    Dim rngFound As Range
    Dim rngNames As Range
    Dim NameCell As Range
    Dim strFirst As String
    Dim strName As String
    Dim strUnqNames As String
    Dim i As Long
    
    Set wsData = Sheets("Data")
    Set wsTemp = Sheets("Template")
    Set rngNames = wsData.Range("A2", wsData.Cells(Rows.Count, "A").End(xlUp))
    
    For Each NameCell In rngNames.Cells
        If InStr(1, "|" & strUnqNames & "|", "|" & NameCell.Text & "|", vbTextCompare) = 0 Then
            strUnqNames = strUnqNames & "|" & NameCell.Text
            Set rngFound = rngNames.Find(NameCell.Text, rngNames.Cells(rngNames.Cells.Count), xlValues, xlWhole)
            If Not rngFound Is Nothing Then
                strFirst = rngFound.Address
                strName = NameCell.Text
                For i = 1 To 7
                    strName = Replace(strName, Mid(":\/?*[]", i, 1), vbNullString)
                Next i
                strName = Trim(Left(WorksheetFunction.Trim(strName), 31))
                If Evaluate("IsRef('" & strName & "'!A1)") = False Then
                    wsTemp.Copy After:=Sheets(Sheets.Count)
                    ActiveSheet.Name = strName
                End If
                With Sheets(strName)
                    Do
                        If LCase(wsData.Cells(rngFound.Row, "I").Text) = "full liquidation" Or LCase(wsData.Cells(rngFound.Row, "I").Text) = "redemption" Then
                            .Cells(68, "A").End(xlUp).Offset(1).Value = wsData.Cells(rngFound.Row, "E").Value
                            .Cells(68, "B").End(xlUp).Offset(1).Value = wsData.Cells(rngFound.Row, "F").Value
                            .Cells(68, "C").End(xlUp).Offset(1).Value = wsData.Cells(rngFound.Row, "B").Value
                            .Cells(68, "D").End(xlUp).Offset(1).Value = wsData.Cells(rngFound.Row, "O").Value
                            .Cells(68, "T").End(xlUp).Offset(1).Value = wsData.Cells(rngFound.Row, "L").Value
                        End If
                        Set rngFound = rngNames.Find(NameCell.Text, rngFound, xlValues, xlWhole)
                    Loop While rngFound.Address <> strFirst
                End With
            End If
        End If
    Next NameCell
    
    Set wsData = Nothing
    Set wsTemp = Nothing
    Set rngFound = Nothing
    Set rngNames = Nothing
    Set NameCell = Nothing
    
End Sub

 

[swoldu]

I thank you for all your assistance everything worked out fine except for the line
.Cells(Rows.Count, "A").End(xlUp).Offset(1).Value = wsData.Cells(rngFound.Row, "E").Value
I tried putting the row count to 68 but that did not work either (also I needed it to start in row 4 in the (temp)sheet if that was the reason). I'll really do appreciate all your help, I'm going to see if I could figure out this one out myself.

Cheers swoldu