I have a workbook with three sheets: Collections, Client and Interest
New sheets created from a range in Sheets("Interest"). The range in Sheets("Interest") holds the client names.
Then the template in Sheets("Client") is copied and pasted into the new sheets
For each new sheets cell B6 holds the client name and .Range("A10:A1317") holds the dates
Sheets("Collections").Range("D10:D1317") holds the dates and .Range("D8:WC8") holds the Client Names
if Sheets("Collections").Range("D8:WC8") = new sheet.cells(6, 4) then
if Sheets("Collections").Range("D10:D1317") = new sheet .range("A10:A1317") then
copy the value in Sheets("Collections").Range("D10:WC10").offset(0, 3) to new sheet .Range("C10:C1317")
end if
move down on row and repeat the steps
Sub CreateSheetsFromAList()
Dim MyCell As Range, MyRange As Range
Dim MyClients As Range, MyColClients As Range, MyIntClients As Range
Dim clientNAME As String
With Sheets("Interest")
Set MyIntClients = .Range("A5:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With
With Sheets("Collections")
Set MyColClients = .Range("D8").Offset(0, 3).End(xlToLeft).Column
Set colDATE = .Range("A10:A1317")
End With
For Each MyCell In MyIntClients
If Trim(MyCell.Value) <> "" Then 'checks if cell is not empty
If Not SheetExists(MyCell.Value) Then 'check if worksheet already exists
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
'Copy worksheet("Client") to new worksheets
Sheets("Client").Cells.Copy
'paste to new worksheet
Sheets(Sheets.Count).Paste
'Fill cell B6 of new worksheets with client name
ActiveSheet.Range("B6") = Sheets(Sheets.Count).Name
'script to populate cells starts here
'get the value of cell B6 into the string named clientNAME
clientNAME = ActiveSheet.Range("B6").Value
If clientNAME = MyColClients.Value Then 'Counter moves right until end of row (last column)
If colDATE = ActiveSheet.Range("B10:B1317").Value Then 'checks if date on collection sheet same as client worksheet
Sheets("Collections").Range("D10").Offset(0, 3).End(xlToLeft).Column.Copy
ActiveSheet.Range("C10").Paste
End If
Sheets("Collections").Range("D10").Offset(1, 0).Select 'move one row down and repeat the condition above
End If
End If
End If
Next MyCell
End Sub
Function SheetExists(shName As String) As Boolean
Dim sh As Object
SheetExists = False
For Each sh In Sheets
If sh.Name = shName Then
SheetExists = True
Exit For
End If
Next sh
End Function
Bookmarks