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

Question

Итак, сначала вот как выглядят мои исходные данные: SampleData

Окончательный вывод: Выход для «AAM, PCM»

Для каждого кода ветви в столбце A я хочу скопировать и вставить эти ячейки (не всю строку) в другую книгу, а затем сохранить эту книгу в качестве имени кода ветви. Этот код, приведенный ниже, отлично подходит для копирования и вставки в новые листы одной и той же книги, но я не могу изменить его в соответствии со своими потребностями. Они используют «изменение размера» в качестве метода вставки, с которым я не знаком

Sub columntosheets()

Const sname As String = "Sheet1" 'change to whatever starting sheet
Const s As String = "A" 'change to whatever criterion column

Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With Sheets(sname)
    rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    cc = .Columns(s).Column
End With
For Each sh In Worksheets
    d(sh.Name) = 1
Next sh

Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(sname))
Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
    If a(i, 1) <> a(p, 1) Then
        If d(a(p, 1)) <> 1 Then
            Sheets.Add.Name = Left(a(p, 1), 25)
            .Cells(1).Resize(, cls).Copy Cells(1)
            .Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
        End If
        p = i
    End If
Next i
Application.DisplayAlerts = False
    .Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
Sheets(sname).Activate

End Sub

Я пробовал несколько других методов и, похоже, ничего не получалось. Любая помощь будет оценена!

Предыдущий код, который я использовал для создания рабочих книг, используя список имен веток и функцию SaveAs

For Each cell In MyRange 
    cell.Copy ws1.Range("I2").PasteSpecial ActiveWorkbook.SaveAs 
    Filename:="C:\Users\34389\Documents\test" & Range("I2").Value 
Next cell