问VBA Excel基于单元格值自动生成用于递增单元格的新工作表

EN

 Sub Namedsheetsadding()
 Dim wsr As Worksheet, wso As Worksheet
 Dim i As Long, xCount As Long
 Dim SheetNames As Variant   'This needs to be variant
 Dim sheetname As Variant
 Dim newsheet As Worksheet
 Dim lr As Long
 
 Set wsr = ThisWorkbook.Sheets("Vetro Area Map 1")

 lr = ThisWorkbook.Sheets("Frontsheet").Cells(Rows.Count, 4).End(xlUp).Row 'Get last row
 SheetNames = ThisWorkbook.Sheets("Frontsheet").Range("D122:D" & lr)  'including empty cells either, but not creating new sheets for them
 SheetNames = Application.Transpose(Application.Index(SheetNames, , 1)) 'Converts the 2d array into a 1d array
 For i = 1 To ActiveWorkbook.Sheets.Count
    If InStr(1, Sheets(i).Name, "Vetro") > 0 Then xCount = xCount + 1
 Next

 For Each sheetname In SheetNames
    wsr.Copy After:=ActiveWorkbook.Sheets(wsr.Index - 1 + xCount)
    Set newsheet = Sheets(wsr.Index + xCount)
    newsheet.Name = "Vetro Area Map " & sheetname
    xCount = xCount + 1 'Preserve order of sheets from range
 Next
 End Sub

Sub makeNewWorksheets()
 Dim wsr As Worksheet, wso As Worksheet
 Dim i As Long, xCount As Long
 Dim SheetName As String

 Dim startTingCell As Range
    Set startTingCell = Range("D122")
    
 For i = 1 To ActiveWorkbook.Sheets.Count
   If InStr(1, Sheets(i).Name, "Vetro") > 0 Then xCount = xCount + 1
 Next

        'Changes the cell being referenced by xCount
            Set startTingCell = startTingCell.Offset(xCount, 0)
            
        'helps explain what is happening. Delete after you've grasped what's up.
        MsgBox "The cell that will be set to the name is " & startTingCell.Address & _
        "with a value of " & startTingCell.Value
        
        wsr.Copy After:=ActiveWorkbook.Sheets(wsr.Index - 1 + xCount)
        ActiveSheet.Name = "Vetro Area Map " & startTingCell.Value
        
End Sub