有没有一种方法可以将Excel电子表格按行值拆分为不同的文件？

问题描述

我有一个很大的Excel工作表，其中包含针对不同客户的单独评估报告，这些报告都合并为一个大工作表。我需要将此巨型工作表拆分为每个客户单独的报告文件，然后转换为pdf。

我无法按行数进行拆分，因为行数差异很大。

但是，“ [SUMMARISED]”和饼图的图像出现在每个新的单独报告之前的每一行上。这意味着“ [SUMMARISED]”之前的行是断点。

我可以根据这个单词拆分此工作表中的数据吗？

Net Asset Value is the last row of the previous report,'[SUMMARISED]' is the start of a new one

'[SUMMARISED]'在A列中

Top part of the Excel sheet

Error message

Debug error

解决方法

请尝试下一个代码，

Sub testSplitSheetContentSumm()
 Dim sh As Worksheet,lastRow As Long,wb As Workbook,ws As Worksheet,count As Long
 Dim rng As Range,strSearch As String,sumCell As Range,startRow As Long
 Dim firstFAddress As String,wbName As String,k As Long,strPath As String
 
 strSearch = "[SUMMARISED]"
 Set sh = ActiveSheet ' use here your sheet
 strPath = ActiveWorkbook.Path
 lastRow = sh.Range("A" & Rows.count).End(xlUp).Row
 
 Set rng = sh.Range("A1:A" & lastRow)
 
 'for speed optimization______________________
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 Application.EnableEvents = False
 '____________________________________________
 
 startRow = 1
 Set sumCell = rng.Find(What:=strSearch,After:=sh.Range("A1"),LookIn:=xlValues)
 If Not sumCell Is Nothing Then
    firstFAddress = sumCell.Address
    wbName = sumCell.Offset(2,1).Value
    'correct the workbook name from ilegal characters
    wbName = Replace(Replace(wbName,"/","-"),"""","")
    Do
        k = k + 1
        If k = 1 Then GoTo Over
        count = count + 1 'how many files has been saved
        Set wb = Workbooks.Add: Set ws = wb.Sheets(1)
        sh.Range(sh.cells(startRow,1),sh.cells(sumCell.Row - 1,sh.UsedRange.Columns.count)).Copy _
                                                                    Destination:=ws.Range("A1")
        startRow = sumCell.Row
        'saving the workbook:
        Application.DisplayAlerts = False 'to avoid the screen asking for permition to overwrite existing
         wb.SaveAs strPath & "\" & wbName
        Application.DisplayAlerts = True
          'saving the pdf:
          ws.Activate
          ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF,Filename:= _
                    strPath & "\" & wbName & ".pdf"
         
        wb.Close False
        wbName = sumCell.Offset(2,1).Value
        wbName = Replace(Replace(wbName,"")
Over:
        Set sumCell = rng.FindNext(sumCell)
        
    Loop While Not sumCell Is Nothing And sumCell.Address <> firstFAddress
    'now,the last part should be saved,too:
     Set wb = Workbooks.Add: Set ws = wb.Sheets(1)
        sh.Range(sh.cells(startRow,sh.cells(lastRow,sh.UsedRange.Columns.count)).Copy _
                                                                  Destination:=ws.Range("A1")
        Application.DisplayAlerts = False
         wb.SaveAs strPath & "\" & wbName
        Application.DisplayAlerts = True
        
          ws.ExportAsFixedFormat Type:=xlTypePDF,Filename:= _
                    strPath & "\" & wbName & ".pdf",Quality:= _
                    xlQualityStandard,IncludeDocProperties:=False,IgnorePrintAreas:=False
        wb.Close False
 Else
    MsgBox "The word """ & strSearch & """ could not be found..."
 End If
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
 Application.EnableEvents = True
 MsgBox count & " files have been saved in """ & strPath & """ folder.",_
                                              vbInformation,"Job done..."
End Sub

已编辑：您遇到的问题是由于用于构建文件名的字符串包含回义字符而产生的。现在，代码将/替换为-，并删除了"。新创建文件的保存路径将是要处理的文件的路径。