VBA Excel autopopulate new sheets based on the cell value in correct order

Question

Regarding my last query:

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

I would like to have this sheet population in the correct order, as I have more than 1 sheet name to populate.

I have 2 sheets with the basic reference of the name. They are marked red in the image below:

After applying the code below:

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

I am getting the wrong order of these sheet names. I need them to appear interchangeably, as you could see below:

I tried also something like this:

 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

but I am getting an error:

Subscript out of range

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

Te same error occurs with this approach:

  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

Again, it would be so much easier if you didn't obscure the sheet names in your screenshot. Also Explain in words the exact process you want to follow when creating the new sheets - eg. "for each sheet name in the range SheetNames, copy the existing sheets 'Vetro Area Map 1' and 'Area Map Op 1' after ......" — Tim Williams
These names might be confidential. That's why I decided to change the tab colours instead. I want the Vetro Map 1 and Op Map 1 next Vetro Map 0085a and Op Map 0085a, Vetro Map 0085b, Op Map 0085b and so on to appear interchangeably. — MKR

Tim Williams Tim Williams · Accepted Answer · 2021-03-18T23:16:33

Here's how I'd probably do it:

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

Method for copying sheets:

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

VBA Excel autopopulate new sheets based on the cell value in correct order

1 Answers