Create new sheets Named from cells and Auto-Populate with information from Master sheet

Question

I have a master sheet of names and addresses like this:

Company Type        First   Last    TITLE           EMAIL           PHONE       US_MAIL_AD  US_MAIL_ADline2 CITY    STATE   ZIP
A       Telephone   Matt    Smith                   [email protected]    265-3555    240 N       Indianapolis    IN      2222
B       Water       John    Cook    Design Engineer [email protected]   265-3333    241 N       Indianapolis    IN      22222

I also have a second sheet containging a template for a phone log with a header that that will include the addresses, etc. but not in the same row format.

I want excel to automatically create a new sheet for each company, which I have already figured out(below), but I need the new sheets to contain the header from the template sheet populated with the address information. So is there a way to copy in specific cells in the same function as the one that creates the sheets?

Public Function WorkSheetExists(SheetName As String, wrkbk As Workbook) As Boolean
    Dim wrkSht As Worksheet
    On Error Resume Next
        Set wrkSht = wrkbk.Worksheets(SheetName) 'Attempt to set reference to worksheet.
        WorkSheetExists = (Err.Number = 0) 'Was an error generated - True or False?
        Set wrkSht = Nothing
    On Error GoTo 0
End Function
Sub AddSheets()
    Dim MyCell As Range, MyRange As Range
    Dim wbToAddSheetsTo As Excel.Workbook
    Set MyRange = Sheets("Project Contact List").Range("B2")
    Set MyRange = Range(MyRange, MyRange.End(xlDown))
    Set wbToAddSheetsTo = ActiveWorkbook
    For Each MyCell In MyRange
        If Not (WorkSheetExists(MyCell.Value, wbToAddSheetsTo)) Then
                Sheets.Add After:=Sheets(Sheets.Count)
                Sheets(Sheets.Count).Name = MyCell.Value
                On Error Resume Next
                ActiveSheet.Name = MyCell.Value
                'If Err.Number = 1004 Then
                '    Debug.Print cell.Value & " already used as a sheet name"
                'End If
                On Error GoTo 0
        End If
    Next MyCell
End Sub

SJR SJR · Accepted Answer · 2018-03-27T16:10:46

Not sure exactly what info you want to transfer, but something like this will do it.

Sub AddSheets()

Dim MyCell As Range, MyRange As Range, ws As Worksheet
Dim wbToAddSheetsTo As Excel.Workbook

With Sheets("Project Contact List")
    Set MyRange = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
End With
Set wbToAddSheetsTo = ActiveWorkbook
For Each MyCell In MyRange
    If Not WorkSheetExists(MyCell.Value, wbToAddSheetsTo) Then
        Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
        ws.Name = MyCell.Value
        MyCell.Offset(, 1).Resize(, 9).Copy ws.Range("A1")
    End If
Next MyCell

End Sub

Create new sheets Named from cells and Auto-Populate with information from Master sheet

1 Answers