VBA Excel根据单元格值以正确的顺序自动填充新工作表

Question

关于我上次的查询：

VBA Excel autopopulate new sheets based on the cell value for incrementing cells

我希望以正确的顺序填充此工作表，因为我有超过 1 个工作表名称要填充。

我有 2 张纸，上面有名字的基本参考。它们在下图中被标记为红色：

应用以下代码后：

Sub Sheetwithnames2()
      Dim wsr As Worksheet, wso As Worksheet
      Dim i As Long, j As Long, xCount As Long, yCount As Long
      Dim SheetNames As Variant, LSheetNames As Variant   'This needs to be variant
      Dim sheetname As Variant, lsheetname As Variant
      Dim newsheet As Worksheet, lnewsheet As Worksheet, onewsheet As Worksheet, olnewsheet As Worksheet
      Dim lr As Long, lro As Long

      Set wsr = ThisWorkbook.Sheets("Vetro Area Map 1")
      Set wso = ThisWorkbook.Sheets("Area Map Op 1")

      lr = ThisWorkbook.Sheets("Frontsheet").Cells(Rows.Count, 4).End(xlUp).Row 'Get last row
      lro = ThisWorkbook.Sheets("Frontsheet").Cells(Rows.Count, 5).End(xlUp).Row 'Get last row
      'including empty cells either, but not creating new sheets for them
      SheetNames = ThisWorkbook.Sheets("Frontsheet").Range("D123:D" & lr)  

      SheetNames = Application.Transpose(Application.Index(SheetNames, , 1)) 'Converts the 2d array into a 1d array

      LSheetNames = ThisWorkbook.Sheets("Frontsheet").Range("E123:E" & lro)

      For i = 1 To ActiveWorkbook.Sheets.Count
      If InStr(1, Sheets(i).name, "Vetro") > 0 Then xCount = xCount + 1
      Next

      For j = 1 To ActiveWorkbook.Sheets.Count
      If InStr(1, Sheets(j).name, "Op") > 0 Then yCount = yCount + 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 & " 1"
      xCount = xCount + 1 'Preserve order of sheets from range
      wso.Copy After:=ActiveWorkbook.Sheets(wso.Index - 1 + yCount)
      Set onewsheet = Sheets(wso.Index + yCount)
      onewsheet.name = "Area Map Op " & sheetname & " 1"
      yCount = yCount + 1

      Next

End Sub

我得到这些工作表名称的错误顺序。我需要它们交替出现，如下所示：

我也试过这样的：

 For i = 1 To ActiveWorkbook.Sheets.Count
 If InStr(1, Sheets(i).name, "Vetro") > 0 Then xCount = xCount + 1
 Next

 For j = 1 To ActiveWorkbook.Sheets.Count
 If InStr(1, Sheets(j).name, "Op") > 0 Then yCount = xCount + 2
 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 & " 1"
 xCount = xCount + 1 'Preserve order of sheets from range
 wso.Copy After:=ActiveWorkbook.Sheets(wso.Index - 1 + yCount)
 Set onewsheet = Sheets(wso.Index + yCount)
 onewsheet.name = "Area Map Op " & sheetname & " 1"
 yCount = yCount + 1

 Next

但我收到一个错误：

下标超出范围

     wso.Copy After:=ActiveWorkbook.Sheets(wso.Index - 1 + yCount)

这种方法也会出现同样的错误：

  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 * 2 + 1)
 Set newsheet = Sheets(wsr.Index + xCount)
 newsheet.name = "Vetro Area Map " & sheetname & " 1"
 xCount = xCount + 1 'Preserve order of sheets from range
 wso.Copy After:=ActiveWorkbook.Sheets(wso.Index - 1 + xCount * 2 + 2)
 Set onewsheet = Sheets(wso.Index + xCount)
 onewsheet.name = "Area Map Op " & sheetname & " 1"
 xCount = xCount + 1

 Next

Answer 1

我可能会这样做：

'...
'...
For Each sheetname In SheetNames
     CopyTemplates sheetname 
Next
'...
'...

复印纸的方法：

Sub CopyTemplates(newName As String)
    'these are the template worksheets
    Const WS_A As String = "Vetro Area Map 1"
    Const WS_B As String = "Area Map Op 1"
    
    Dim wsLast As Worksheet, i As Long, ws As Worksheet
    
    'find the last worksheet which looks like one of our templates
    '  (or a copy of one of the templates)
    For i = 1 To ThisWorkbook.Worksheets.Count
        Set ws = ThisWorkbook.Worksheets(i)
        If ws.Name Like "Vetro Area*" Or ws.Name Like "Area Map*" Then
            Set wsLast = ws
        End If
    Next i
    'copy the templates after the "last" copy and rename
    With ThisWorkbook.Worksheets
        .Item(Array(WS_A, WS_B)).Copy after:=wsLast
        .Item(wsLast.Index + 1).Name = "Vetro Area Map " & newName & " 1"
        .Item(wsLast.Index + 2).Name = "Area Map Op " & newName & " 1"
    End With

End Sub