VBA copy sheets, rename based on cell value and paste a value on new sheet

[HatBird]

Hi all! Before I start, I just want to say my knowledge of VBA is very basic. I'm trying to learn by recording macros.

I currently have a workbook with 5 sheets: 'New project', 'Template_General', 'Template_Budget', 'Template-Planning' and 'Template-Notes'.
On the sheet 'New project' I ask users to write a projectcode in cell A5. The projectcode consists of a combination of two letters and three numbers (e.g. 'AB001'). On this sheet I would like to add a button that performs multiple steps:
1. Copy the sheet 'Template_General'
2. Rename this sheet to the last three characters of the projectname (as stated in cell A5 on the 'New project' sheet) & the word 'General'.
3. Copy the projectcode from the 'New project' sheet in cell A5 and paste this value to the newly created sheet in cell D7.
4. Steps 1-3 for the other templates (budget, planning and notes).
5. Clear cell A5 on sheet 'New project'
6. Navigate to the newly created 'General' sheet, cell A1.

Optionally, I would like to show a custom error message if the sheetname already exists.

Any help or advise is much appreciated!

 

[Wookiee]

Hello and welcome to MrExcel!

I put together a macro for you. I should mention that it requires a standard naming convention for your sheets (2 had underscores and 2 had dashes). By changing them all to have dashes, it's a simple matter of replacing the "Template-" portion of the name to rename all the sheets. I hope this helps.

Sub HatBird()
'Crafted by Wookiee at MrExcel.com


Dim lngLoop          As Long
Dim strLast3         As String
Dim strProjectCode   As String
Dim strSheet         As String
Dim arrSheets        As Variant
Dim rngProjectCode   As Range

arrSheets = Array _
  ("Template-General", "Template-Budget", "Template-Planning", "Template-Notes")

Set rngProjectCode = ThisWorkbook.Sheets("New Project").Range("A5")

strProjectCode = rngProjectCode.Value

For lngLoop = LBound(arrSheets) To UBound(arrSheets)

  strSheet = arrSheets(lngLoop)

  Sheets(strSheet).Copy After:=ThisWorkbook.Sheets(Sheets.Count)
  
  With ActiveSheet
  
    strLast3 = Right(strProjectCode, 3)
    .Name = Replace(.Name, "Template-", strLast3 & " ")
    .Range("D7") = strProjectCode

  End With

Next lngLoop

With rngProjectCode

  .Parent.Activate
  .ClearContents

End With

End Sub

 

[HaHoBe]

Hi HatBird,

what about

Public Sub MrE_1232582_1704B0F()
' https://www.mrexcel.com/board/threads/vba-copy-sheets-rename-based-on-cell-value-and-paste-a-value-on-new-sheet.1232582/

Dim wsNP As Worksheet
Dim strTarg As String
Dim strNP As String
Dim lngPos As Long
Dim blnCont As Boolean
Dim avarTemplates As Variant
Dim varItem As Variant
Dim strShName As String

On Error GoTo err_here
Set wsNP = ThisWorkbook.Worksheets("New project")

'checking Project to have 2 Characters and 3 Numbers
strNP = wsNP.Range("A5").Value
For lngPos = 1 To 5
  Select Case lngPos
    Case 1 To 2
      Select Case Asc(Mid(strNP, lngPos, 1))
        Case 65 To 90, 97 To 122
          blnCont = True
        Case Else
          blnCont = False
          Exit For
      End Select
    Case Else
      Select Case Asc(Mid(strNP, lngPos, 1))
        Case 48 To 57
          blnCont = True
        Case Else
          blnCont = False
          Exit For
      End Select
  End Select
Next lngPos
If blnCont = False Then
  MsgBox "Project number not according to rule, check in A5.", vbInformation, "Ending here"
  GoTo err_here
End If

'Loop through the templates to copy only if sheet does not exist
avarTemplates = Array("Template_General", "Template_Budget", "Template-Planning", "Template-Notes")
For Each varItem In avarTemplates
  strShName = Mid(varItem, 10) & Right(strNP, 3)
  If Not Evaluate("ISREF('" & strShName & "'!A1)") Then
    Worksheets(varItem).Copy after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = strShName
    ActiveSheet.Range("D7").Value = strNP
  Else
    MsgBox strShName & " already exists in this workbook, ending code here!", vbInformation, "Project number has already been used"
    GoTo err_here
  End If
Next varItem
wsNP.Range("A5").Value = vbNullString
Application.Goto Worksheets(strShName).Range("A1")

err_here:
  If Err.Number <> 0 Then
    Select Case Err.Number
      Case 9
        MsgBox "Please check the names of the sheets to suit the names in the code.", vbInformation, "Sheetnames wrong or missing"
      Case Else
        MsgBox "Error " & Err.Number & " occurred." & vbCrLf & "Descripton: " & Err.Description, vbExclamation, "Some error occirred"
    End Select
  End If
  Set wsNP = Nothing
End Sub

Ciao,
Holger