厚労省から依頼の調査で、どうしても１件１件カルテを見なければならない調査があり、担当者を振り分け、その担当者ごとにExcelファイルを配布することにしました。
そこで、ファイルを分割するためのＶＢＡをＣＨＡＴＧＰＴに教えてもらいました。
その際のプロンプトの実例です。

実例
「このExcelシート（公開されているフォーマットかつ、個人情報や、機関を特定する情報がないファイルをアップロード）おけるD列の18行目以降に、入力された文字列毎に分割したファイルを作るVBAのコードを書いたExcelファイルを作ってください。
・シート名は、D列１８行目以降の文字列
・分割したファイルでは、指定した文字列以外の行は消す
・元のファイルのの１行目から１７行目は、分割後も残す
・D列１８行目以降でソート
・D列が同じ文字列となった行をまとめて、新しいbookにする
・保存先のフォルダを指定するコードも入れる。
以上の条件で、VBAのコードを書いてください。」

以下が出てきたものです。

Sub SplitWorkbookBasedOnDColumn()
Dim OriginalWs As Worksheet
Dim NewWb As Workbook
Dim NewWs As Worksheet
Dim LastRow As Long
Dim r As Long, newRow As Long
Dim HeaderRange As Range
Dim CurrentValue As String
Dim SavePath As String

' Set the original worksheet
Set OriginalWs = ThisWorkbook.Sheets(1)

' Set the range for header (rows 1 to 17)
Set HeaderRange = OriginalWs.Range("A1:Z17")

' Sort column D from row 18 onwards
LastRow = OriginalWs.Cells(OriginalWs.Rows.Count, 4).End(xlUp).Row
OriginalWs.Range("A18:Z" & LastRow).Sort Key1:=OriginalWs.Range("D18"), Order1:=xlAscending, Header:=xlNo

' Specify the save path
SavePath = "C:\YourDesiredPath\"  ' Change this to your desired folder path

r = 18
Do While r <= LastRow
    CurrentValue = OriginalWs.Cells(r, 4).Value
    
    If CurrentValue <> "" Then
        ' Create a new workbook and worksheet
        Set NewWb = Workbooks.Add
        Set NewWs = NewWb.Sheets(1)

        ' Copy the header
        HeaderRange.Copy NewWs.Range("A1")

        ' Initialize newRow for the new workbook
        newRow = 18

        ' Loop until the value in column D changes
        Do While OriginalWs.Cells(r, 4).Value = CurrentValue And r <= LastRow
            ' Copy the current row to the new workbook
            OriginalWs.Rows(r).Copy NewWs.Rows(newRow)

            ' Move to the next row in both the original and new workbooks
            r = r + 1
            newRow = newRow + 1
        Loop

        ' Save the new workbook with the value in column D as the name
        NewWb.SaveAs SavePath & CurrentValue & ".xlsx"
        NewWb.Close SaveChanges:=True
    Else
        r = r + 1
    End If
Loop
End Sub

パスと列の範囲の指定だけ変更すれば、そのまま使えました。

合体させるのには、以下のプロンプトを書きました。

１指定したフォルダ内にあるすべてのファイルの１８行目から下のデータのある行についてA列からＺ列までコピー
２コピーしたデータを貼り付け
３書式はそのままで貼り付ける
４コピー貼り付けを繰り返し
５貼り付けは、下に追加していく。
こちらを実行できるVBAのコードを教えてください。

出てきたのが以下のコードです。

Sub CopyFrom18thLine()
Dim SourceWorkbook As Workbook
Dim TargetWorkbook As Workbook
Dim SourceWorksheet As Worksheet
Dim TargetWorksheet As Worksheet
Dim LastRow As Long
Dim LastTargetRow As Long
Dim folderPath As String
Dim fileName As String

' 現在のワークブックをターゲットとして設定
Set TargetWorkbook = ThisWorkbook
Set TargetWorksheet = TargetWorkbook.Sheets(1) ' 1番目のシートにデータを貼り付ける

' フォルダのパスを指定（最後の\を含める）
folderPath = "C:\path\to\your\folder\" ' <--- こちらを変更してください

' フォルダ内の最初のExcelファイルの名前を取得
fileName = Dir(folderPath & "*.xls*")

' ファイルがなくなるまでループ
Do While fileName <> ""

    ' ソースワークブックとしてファイルを開く
    Set SourceWorkbook = Workbooks.Open(folderPath & fileName)
    Set SourceWorksheet = SourceWorkbook.Sheets(1) ' 1番目のシートからデータをコピー

    ' ソースシートの最後の行番号を取得
    LastRow = SourceWorksheet.Cells(SourceWorksheet.Rows.Count, "A").End(xlUp).Row

    ' ターゲットシートの最後の行番号を取得
    LastTargetRow = TargetWorksheet.Cells(TargetWorksheet.Rows.Count, "A").End(xlUp).Row + 1

    ' 18行目から最後の行まで、A列からBX列のデータをコピー
    SourceWorksheet.Range("A18:BX" & LastRow).Copy 
    TargetWorksheet.Cells(LastTargetRow, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats

    ' ソースワークブックを閉じる
    SourceWorkbook.Close SaveChanges:=False

    ' 次のファイル名を取得
    fileName = Dir

Loop

Application.CutCopyMode = False
MsgBox "完了しました"
End Sub

今、見返すと、「書式はそのまま」という一文でよく、Paste:=xlPasteValuesAndNumberFormats
をひねり出してきたなと思いました。
値で貼り付けとかのほうがよかったと思いますが、ちゃんと意図をくみ取っていますね。
なかなかやりますね。

総括
今までなら、途中まで書いて、わからなくなってできる人に泣きついていたかなと思います。
何となく途中まで書けても最後まで一人ではやり切れる自信はありません。
これが、ルーティンでこれからずっとやるとかであれば、泣きながら頑張って時間かけて調べてやるかもしれませんが、一回こっきりであれば、力業でコツコツ分割していたと思います。
それが、たしか１０分くらいでコードが完成しました。
たぶん、コツコツ手作業では、１～２時間はかかったかなという作業と思います。
今までは、関数やピボットを使って何とかやり過ごしていたものが、ちゃちゃっとＶＢＡにできるようになり、かつ、コードのサンプルとして勉強になり、一石二鳥ですね。