Excel sheet splitsen op basis van trefwoord

Sub Hoofdstuk()
   With Sheets("origineel")                      'je werblad
      ThisWorkbook.Names.Add "Totaalkolom", Sheets("origineel").UsedRange.Columns("E")   'een gedefinieerde naam van de E-kolom
      arr = Filter([transpose(if(left(totaalkolom,6)="Totaal",row(totaalkolom),"~"))], "~", 0, vbTextCompare)   'array met alle rijnummers waar totaal in staat
      If UBound(arr) = -1 Then MsgBox "foutje bedankt": Exit Sub   'geen totaals

      For i = 0 To UBound(arr)                   'alle totalen aflopen
         .Range("A1:A" & arr(i)).EntireRow.Copy  'blok kopieren
         naam = Mid(.Cells(arr(i), "E").Value, 8)
         Sheets.Add After:=Sheets(Sheets.Count)  'blad toevoegen
         With ActiveSheet
            .Name = naam
            .Paste
            .Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
         End With
         .Range("A3:A" & arr(i)).EntireRow.Hidden = True   'gekopieerde verbergen
      Next
      .UsedRange.EntireRow.Hidden = False
   End With
   Application.CutCopyMode = False
   Application.Goto Range("A1")
End Sub

 Dim Wsht As Worksheet
 For Each Wsht In Worksheets
 With Wsht.UsedRange
 .EntireRow.AutoFit
 End With
 Next Wsht

Sub VenA()
Set d = CreateObject("Scripting.Dictionary")
  With Sheets("Origineel")
    ar = .Range("A1:G" & .Cells(Rows.Count, 5).End(xlUp).Row)
    For j = UBound(ar) To 1 Step -1
      If Left(ar(j, 5), 6) = "Totaal" Then c00 = Mid(ar(j, 5), 8)
      d(c00) = ""
      ar(j, 7) = c00
    Next j
    .Range("A1:G" & .Cells(Rows.Count, 5).End(xlUp).Row) = ar
    For Each it In d
    .Cells(1).CurrentRegion.AutoFilter 7, it
    .Cells.CurrentRegion.Resize(, 6).Copy
      With Sheets.Add(, Sheets(1))
      'With ActiveSheet
        .Paste
        .Columns.AutoFit
        .Name = it
      End With
    Next it
    .Cells(1).CurrentRegion.AutoFilter
    .Columns(7).Delete
  End With
End Sub

     Next
      [COLOR="#FF0000"]  .Range("A3:F" & arr(UBound(arr))).Clear
     [/COLOR]   .UsedRange.EntireRow.Hidden = False
   End With

       .Range("A3:F" & arr(UBound(arr))).ClearContents
        .Range("E3:E" & arr(UBound(arr))).Clear

Sub Verwijder_verborgen_rijen()
    
  Dim ws As Worksheet
  Dim rVis As Range
 
  Application.ScreenUpdating = False
  
  For Each ws In Worksheets
  
    Do Until ws.Columns("A").SpecialCells(xlVisible).Count = ws.Rows.Count
      Set rVis = ws.Columns("A").SpecialCells(xlVisible)
      If rVis.Row = 1 Then
        ws.Rows(rVis.Areas(1).Rows.Count + 1 & ":" & rVis.Areas(2).Row - 1).Delete
      Else
        ws.Rows("1:" & rVis.Row - 1).Delete
      End If
    Loop
  
  Next ws
  
  Application.ScreenUpdating = True

End Sub

Sub Herstel_celhoogte()

 Dim Wsht As Worksheet
 
 For Each Wsht In Worksheets
 
 With Wsht.UsedRange
 .EntireRow.AutoFit
 End With
 
 Next Wsht
  
End Sub

With Wsht.UsedRange
.delete   
.EntireRow.AutoFit
end with

Sub Kopieer_sheets_naar_Template()
    
    Dim directory As String, fileName As String, sheet As Worksheet, total As Integer
    Dim fd As Office.FileDialog
    
    Dim wb1 As Workbook, wb2 As Workbook
    Dim sh As Worksheet
    
    Set wb1 = ActiveWorkbook
    
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
      With fd
        .AllowMultiSelect = False
        .Title = "Selecteer VT template"
        .Filters.Clear
        .Filters.Add "Excel 2003", "*.xls?"
    
        If .Show = True Then
          fileName = Dir(.SelectedItems(1))
    
        End If
      End With

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True

  Workbooks.Open (fileName)
  
  Set wb2 = ActiveWorkbook

   For Each sh In wb1.Sheets
      sh.Copy after:=wb2.Sheets(4)
      
   Next sh

End Sub

     sh.Copy after:=wb2.Sheets(wb2.sheets.count)   ???

sh.Copy before:=wb2.Sheets("Bepaalde naam")