そして作成したそのブックの中には、これからデータを書き込んでいくための、ひな形をコピーしてやる、 というような、ちょっと作業をさせるという形のブックの大量生産です。

フォルダーも大量生産するので、Microsoft Scripting Runtime Libraryを参照することにします。

Sheet1、こちらに従業員の氏名一覧があって、 Sheet2というのはデータ用のひな形があるという設定にします。

今回はシートの名前をデフォルト設定のまま、Sheet1、Sheet2というその名前のまま使っています。 特にコード名を変更するということはしてません。
Dim ws As Worksheet
wsはワークシートの意味の略で変数にして使いやすくしているのです。
Set ws = ThisWorkbook.Sheets("Sheet1")
wsというワークシート変数をSheet1の意味で使いますと設定しています。

コードの最初には Application.ScreenUpdating = False　と記述し
終わりには終わったということで
このApplication.ScreenUpdating = True
にしてやっています。

FileSystemObjectのCreateFolder　メソッド　を使用しますので、以下のように宣言します。
Dim fso As FileSystemObject
Set fso = New FileSystemObject　
宣言とセットの部分を1行にまとめて記述することもできます。
Dim fso As FileSystemObject: Set fso = New FileSystemObject
ここまでのコードは前置きで、いわゆる設定部分です。

メインのコードがこちらになります。
For i = 1 To lastRow
’間にコード
Next i
までの部分です。

実行すると、指定したフォルダに従業員名のフォルダが作成され、その中には従業員名のブックがひな形をコピーした形で作成されています。これなら手間なしです。

コードに戻ります。
fnameは、wsに記述してある従業員の名前です。そしてfPath　というのは、これからフォルダ作成に使うパスですが、 そのフォルダパスにはfnameが含まれていますので、従業員の名前のフォルダパスということになります。

        Dim fPath As String, fname As String
        fname = ws.Cells(i, "A").Value
        fPath = "D:\従業員\" & fname

次のコードは、もし指定したパスにフォルダーが無ければ、フォルダーを作りなさいという命令です。
これにより、ws（Sheet1）に記述された従業員名でフォルダが作成されます。

        If Not fso.FolderExists(fPath) Then
            fso.CreateFolder (fPath)
        End If

次のコード部分からブックを作成します。
Dim newbk As Workbook: Set newbk = Workbooks.Add
作成したブックにws2のUsedRangeをCopyします。
ws2.UsedRange.Copy newbk.Sheets(1).Range("A2")
作成したブックの名前を fnameにします。
newbk.Sheets(1).name = fname
さらにRange("A1").Valueに対してもfnameを入れています。
newbk.Sheets(1).Range("A1").Value = fname
以下のコードはfPathに fnameという名前をつけてブックを保存します。
newbk.SaveAs fPath & "\" & fname & ".xlsx"
作業の最後にCloseします。
newbk.Close

動画で使用したマクロコード全体です。

Sub CreateFoldersAndWorkbooks()
    Application.ScreenUpdating = False
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
    Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")

    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Dim fso As FileSystemObject: Set fso = New FileSystemObject
    
    Dim i As Long
    For i = 1 To lastRow
        Dim fPath As String, fname As String
        fname = ws.Cells(i, "A").Value
        fPath = "D:\従業員\" & fname

        If Not fso.FolderExists(fPath) Then
            fso.CreateFolder (fPath)
        End If

        Dim newbk As Workbook: Set newbk = Workbooks.Add
        
        ws2.UsedRange.Copy newbk.Sheets(1).Range("A2")
        newbk.Sheets(1).name = fname
        newbk.Sheets(1).Range("A1").Value = fname
        newbk.SaveAs fPath & "\" & fname & ".xlsx"
        newbk.Close
    Next i
    Application.ScreenUpdating = True
    MsgBox "End"
End Sub