根据列表复制工作表和单元格值，并使用 excel vba 代码根据列表重命名

Question

i am very new to vba, currently i am looking for code to copy cell values from list to multiple sheet in specific cell

what i am trying to do is as per bellow sheet "point" i have a list with values column B are the names and C & D are values

i need to copy sheet named "template" and rename as per the values in Column B and the values are un defined and be upto any length list sheet

template

currently i am using bellow code to copy sheet and rename as per list

Sub CopySheetRenameFromCell()

Dim sh1 As Worksheet, sh2 As Worksheet, c As Range
Set sh1 = Sheets("template")
Set sh2 = Sheets("point")
For Each c In sh2.Range("B6", sh2.Cells(Rows.Count, 2).End(xlUp))
sh1.Copy After:=Sheets(Sheets.Count)
On Error Resume Next
ActiveSheet.Name = c.Value:
On Error GoTo 0
Next
End Sub

result sheet

but i have no idea how can i copy value from "point" Sheet Column C and D values 1 & 51 to sheet "a" Column C2 and F2 and so on

a values in sheet "a" b values in sheet "b" and on

awaiting your help

Answer 1

Copy Template Worksheet

• This is a basic code. It assumes that each of the cells of the range B6:BLastRow contains a valid value for naming a worksheet. It also assumes that each of the worksheets to be created does not exist already.

Option Explicit

Sub CopySheetRenameFromCell()

    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source worksheet ('sws').
    Dim sws As Worksheet: Set sws = wb.Worksheets("Point")
    
    ' Calculate the source last row ('slRow'),
    ' the row of the last non-empty cell in the column.
    Dim slRow As Long
    slRow = sws.Cells(sws.Rows.Count, "B").End(xlUp).Row
    
    ' Reference the template worksheets ('tws').
    Dim tws As Worksheet: Set tws = wb.Worksheets("Template")
    
    ' Declare additional variables.
    Dim dws As Worksheet ' Current Destination (Copied) Worksheet
    Dim sr As Long ' Current Row in the Source Worksheet
    
    ' Loop through the rows of the source worksheet.
    For sr = 6 To slRow
         ' Create a copy of the template worksheet after the last sheet
         ' in the workbook.
         tws.Copy After:=wb.Sheets(wb.Sheets.Count)
         ' Reference this copy, the destination worksheet,
         ' which is the last (work)sheet in the workbook.
         Set dws = wb.Sheets(wb.Sheets.Count)
         ' Rename the destination worksheet.
         dws.Name = sws.Cells(sr, "B").Value
         ' Write the values from columns 'C' and 'D' in the row ('r')
         ' of the source worksheet to the cells `C2` and `F2` respectively
         ' in the destination worksheet.
         dws.Range("C2").Value = sws.Cells(sr, "C").Value
         dws.Range("F2").Value = sws.Cells(sr, "D").Value
    Next sr
    
    ' Save the workbook.
    'wb.Save
    
    ' Inform.
    MsgBox "Point worksheets created.", vbInformation
    
End Sub