按名称生成工作簿

Sub GenerateWorkbooksPerName()
    
    Const REPEATING_ROWS As Long = 7
    Const NAME_DELIMITER As String = " "
    
    Dim swb As Workbook: Set swb = ThisWorkbook
    Dim sws As Worksheet: Set sws = swb.Worksheets("Consolidated")
    
    Dim FirstRow As Long: FirstRow = REPEATING_ROWS + 1
    
    With sws.UsedRange ' assuming row 1 is not empty:
        If .Rows.Count < FirstRow Then Exit Sub ' no data
    End With
    
    Application.ScreenUpdating = False
    
    sws.Copy ' copy the worksheet to a new single-worksheet workbook
    
    Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count)
    Dim dws As Worksheet: Set dws = dwb.Sheets(1)
    
    With dws.UsedRange ' assuming row 1 is not empty:
        .Resize(.Rows.Count - REPEATING_ROWS).Offset(REPEATING_ROWS).Clear
    End With
    
    Dim dfCell As Range: Set dfCell = dws.Cells(FirstRow, "A")
    
    Dim dFolderPath As String:
    dFolderPath = swb.Path & Application.PathSeparator

    Dim ndLen As Long: ndLen = Len(NAME_DELIMITER)
    
    Dim r As Long, dCount As Long, dFilePath As String, dName As String
    
    For r = FirstRow To sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
        sws.Rows(r).Copy dfCell
        dName = CStr(sws.Cells(r, "A").Value) & NAME_DELIMITER _
            & CStr(sws.Cells(r, "B").Value)
        ' or:
        'dName = CStr(dws.Cells(FirstRow, "A").Value) & NAME_DELIMITER _
            & CStr(dws.Cells(FirstRow, "B").Value)
        If Len(dName) > ndLen Then
            dws.Name = dName
            dFilePath = dFolderPath & dName & ".xlsm"
            Application.DisplayAlerts = False ' overwrite without confirmation
                dwb.SaveAs dFilePath, xlOpenXMLWorkbookMacroEnabled
            Application.DisplayAlerts = True
            dCount = dCount + 1
        End If
    Next r
    
    dwb.Close SaveChanges:=False
    
    Application.ScreenUpdating = True
    
    MsgBox dCount & " workbook" & IIf(dCount = 1, "", "s") & " generated.", _
        IIf(dCount = 0, vbCritical, vbInformation)
    
End Sub

你可能要玩一下这个，但它应该让你开始。如果你需要更多的帮助，让我知道。同时确保您有原始文件的副本以防万一。

Sub Example()
    Dim wbCopy As Workbook
    Dim wsCopy As Worksheet
    Dim wbPaste As Workbook
    Dim wsPaste As Worksheet
    Dim NewWbName As String
    Dim lrow As Long
    Dim i As Long

    Application.ScreenUpdating = False
    
    Set wbCopy = ThisWorkbook
    Set wsCopy = wbCopy.Worksheets("Consolidated")
    
    lrow = wsCopy.Cells(Rows.Count, "A").End(xlUp).Row 'find last row

    For i = 2 To lrow 'loop from 2nd row in worksheet to last row that contains data
        Set wbPaste = Workbooks.Open("C:\Documents\template.xlsx") 'path to template workbook
        Set wsPaste = wbPaste.Worksheets("Sheet1")

        With wsPaste
            wsCopy.Range("A" & i, "C" & i).Copy .Range("A1:C1") 'copy current row for columns A:C
            NewWbName = wsCopy.Cells(i, "A") 'name the new workbook according to the value in current row, column A
        End With
        
        wbPaste.SaveAs wbPaste.Path & Application.PathSeparator & NewWbName & ".xlsx"
        wbPaste.Close False 'close template
        
    Next i

    Application.ScreenUpdating = True

End Sub