For giggles, here is a pdfill version. Not sure if it was just my root folder p but it seemed to run better if I copied the pdf if there was just one in the subfolder. This method can merge by folder.

Sub MergeToPDFill()    
    Dim a, f, i As Long, p As String
    Dim p2 As String, r As String, fso As Object
    Dim s As String, k As String
    
    'Parent folder
    p = ThisWorkbook.Path & "\"
    p = "C:\Users\lenovo1\Dropbox\_Excel\pdf\Acrobat\"
    
    'Folder to copy merged pdfs in subfolders to, p2 initional, and r actual.
    p2 = p & "MergedPDFs"
    If Dir(p2, vbDirectory) = "" Then MkDir p2
    'Make a new folder in p2 to store this run's merged pdf files.
    Do
        i = i + 1
        r = p2 & "\Run" & i & "\"
        Loop Until Dir(r, vbDirectory) = ""
    MkDir r
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    'SubFolders Array
    f = Split(CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
    """" & p & """" & " /ad/b/s").StdOut.ReadAll, vbCrLf)
    'Add parent folder to f:
    f(UBound(f)) = Left(p, Len(p) - 1)
    'Debug.Print Join(f, vbCrLf), "done"
    
    'Merge pdfs in subfolders, save merged file in r folder with subfolder's name.pdf.
    For i = 0 To UBound(f)
        k = f(i) & "\" & Dir(f(i) & "\*.pdf")
        If InStr(f(i), p2 & "\") = 0 And Dir(f(i) & "\*.pdf") <> "" Then
            'Need 2 pdfs to merge or pdfill slows and may error
            If Dir <> "" Then  'at least 2 pdfs files exist
                s = """" & "C:\Program Files (x86)\PlotSoft\PDFill\pdfill.exe" & """" & _
                    " MERGE " & _
                    """" & f(i) & "\" & """" & " " & _
                    """" & r & fso.GetFolder(f(i)).Name & ".pdf" & """"
                Shell s, vbHide
                Else
                FileCopy k, (r & fso.GetFolder(f(i)).Name & ".pdf")
            End If
        End If
    Next i
    Set fso = Nothing
    MsgBox "PDF files merged to folder: " & r
End Sub