VBA Excel根据单元格值按正确顺序自动操作新表

Question

关于我的最后一个问题：

VBA Excel根据单元格值自动填充新表以增加单元格

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

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)

Te这种方法会出现相同的错误：

  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