Создать новый лист на основе ячейки и критериев и переместить строку этого листа

Question

У меня есть лист с именами некоторых художников и тэков. Я хочу разделить этот лист, поэтому каждый исполнитель, имеющий более 4 песен, перемещается на другой лист. Лист, который сделан "на лету". Я должен сказать, что у меня нет никакого опыта работы с vba.

У меня есть этот код, который частично выполняет эту работу, но я должен сделать новый лист вручную, но это вполне работа, так как я более 30 уникальных художников.

    Sub MyTool(control As IRibbonControl)



Application.ScreenUpdating = False

'hvis sheet er blank, Stop
    With Worksheets("Ark1")
        If .Range("a1") = "" Then
            MsgBox "Arket må ikke være tomt"
            Exit Sub
        End If
    End With

'Advarsel
If MsgBox("Tryk for at fortsætte" & vbNewLine & "Dette kan ikke fortrydes" & vbNewLine & "Ønsker du at fortsætte", vbYesNo, "Advarsel") = vbNo Then Exit Sub


'Sletter tomme ark
Dim ws As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
For Each ws In Application.Worksheets
If Application.WorksheetFunction.CountA(ws.UsedRange) = 0 Then
  ws.Delete
End If
Next

'Opretter de ark der skal bruges
Sheets.Add.Name = "indbetaling"
Sheets.Add.Name = "b"
Sheets.Add.Name = "a"




'Flytter de ræker der ska flyttes
Dim Check As Range, r As Long, lastrow2 As Long, LastRow As Long

LastRow = Worksheets("Ark1").UsedRange.rows.Count

For r = LastRow To 2 Step -1
If Worksheets("Ark1").Range("b" & r).Value = "a" Then
    Worksheets("Ark1").rows(r).Cut Destination:=Worksheets("a").Range("A" & rows.Count).End(xlUp)(2)
    Worksheets("Ark1").rows(r).Delete

End If

If Worksheets("Ark1").Range("b" & r).Value = "b" Then
    Worksheets("Ark1").rows(r).Cut Destination:=Worksheets("b").Range("A" & rows.Count).End(xlUp)(2)
    Worksheets("Ark1").rows(r).Delete
End If

If Worksheets("Ark1").Range("c" & r).Value > 0 Then
    Worksheets("Ark1").rows(r).Cut Destination:=Worksheets("indbetaling").Range("A" & rows.Count).End(xlUp)(2)
    Worksheets("Ark1").rows(r).Delete
End If
'De rækker der skal slettes
If Worksheets("Ark1").Range("b" & r).Value = "d" Then
      Worksheets("Ark1").rows(r).Delete
End If

If Worksheets("Ark1").Range("b" & r).Value = "c" Then
    Worksheets("Ark1").rows(r).Delete
End If

Next r

'Overskrifter på hver række
Dim headers() As Variant
Dim wb As Workbook

Set wb = ActiveWorkbook

headers() = Array("Dato", "Debit- / Kreditor", "Beløb")
  For Each ws In wb.Sheets
  With ws
  .rows(1).Value = "" 'This will clear out row 1
  For I = LBound(headers()) To UBound(headers())
      .Cells(1, 1 + I).Value = headers(I)
  Next I

End With
Next ws

'total
For Each ws In ActiveWorkbook.Worksheets
With ws
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
  LastRow = .Cells.Find(What:="*", _
            After:=.Range("A1"), _
            LookAt:=xlPart, _
            LookIn:=xlFormulas, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, _
            MatchCase:=False).Row


Else
  LastRow = 1
End If


End With
  ws.Range("B" & LastRow + 1).FormulaR1C1 = "Total"
  ws.Range("C" & LastRow + 1).FormulaR1C1 = "=SUM(R[-" & LastRow & "]C:R[-1]C)"
Next


'border last row
For Each ws In ThisWorkbook.Sheets
  Set LastCell = ws.Cells.Find("*", Cells(1, 1), xlValues, xlPart, xlByRows, xlPrevious)
  If Not LastCell Is Nothing Then
  LastRow = LastCell.Row
  Else
  LastRow = 1
End If

With ws.rows(LastRow).Borders(xlTop)
  .LineStyle = xlContinuous
  .Weight = xlThin
  .ColorIndex = xlAutomatic
End With

With ws.rows(LastRow).Borders(xlBottom)
  .LineStyle = xlDouble
  .Weight = xlThick
  .ColorIndex = xlAutomatic
  End With
Next


'Width
For c = 1 To 3
m = 0 'max width reset
    For Each w In Worksheets
        If w.Columns(c).ColumnWidth > m Then _
    m = w.Columns(c).ColumnWidth
Next w
    For Each w In Worksheets

    w.Columns(c).ColumnWidth = m + 10
    w.Columns("A").ColumnWidth = 12
Next w
Next

'Tænd skærm
Application.ScreenUpdating = True

MsgBox "Done"

End Sub