使用 Excel VBA 将单个工作簿拆分为包含多个工作表的多个工作簿

Question

我有一个带有单个工作表的工作簿，如下所示。

我想根据其中的值将其拆分为包含许多工作表的许多工作簿。 我想根据图片中第 1 列的“n”个唯一值制作“n”个工作簿。我想根据图片中第 2 列的“m”唯一值制作“m”工作表。

每个工作表都包含如图所示的值。 其实我想用3个系列做一个图表。所以我必须制作如图所示的数据表，每个工作表中都有“levels”、“chart_vlaue_1”、“chart_vlaue_2”、“chart_vlaue_3”列。 我还想在每个工作表中生成图表。 请帮我创建一个示例图表。我会努力的。 请帮帮我。

Answer 1

试试下面，下面应该将您的数据分类到正确的工作表/工作簿中，并为每个工作表创建一个图表。 f_Path 是您将保存这些文件的文件路径。如果文件已经存在，代码将跳过这些

Sub main()
Dim f_Path
f_Path = "C:\" 'Filepath to save files to

With ActiveSheet 'run on activesheet
    If .Cells(2, 1).Value <> "" Then 'if A2 not blank
        For Each cell In .Range("A2:" & .Range("A2").End(xlDown).Address)
            If Dir(f_Path & cell.Value & ".xls") <> "" Then
                'exists
                If IsWorkBookOpen(f_Path & cell.Value & ".xls") Then
                     'open
                Else
                    GoTo Skipper 'not open
                End If
                Workbooks(cell.Value & ".xls").Activate

                On Error Resume Next
                Sheets(cell.Offset(0, 1).Value).Select
                If Err.Number <> 0 Then
                    Worksheets.Add().Name = cell.Offset(0, 1).Value
                End If
                On Error GoTo 0
                lastrow = ActiveSheet.Range("A1").End(xlDown).Row - 1
                If lastrow = 1048575 Then 'First time
                    With ActiveSheet
                        .Range("A1").Value = "Levels"
                        .Range("B1").Value = "Chart_Value1"
                        .Range("C1").Value = "Chart_Value2"
                        .Range("D1").Value = "Chart_Value3"
                        .Range("A2").Value = cell.Offset(0, 2).Value
                        .Range("B2").Value = cell.Offset(0, 3).Value
                        .Range("C2").Value = cell.Offset(0, 5).Value
                        .Range("D2").Value = cell.Offset(0, 7).Value
                    End With
                Else
                    With ActiveSheet
                        .Range("A2").Offset(0 + lastrow, 0).Value = cell.Offset(0, 2).Value
                        .Range("B2").Offset(0 + lastrow, 0).Value = cell.Offset(0, 3).Value
                        .Range("C2").Offset(0 + lastrow, 0).Value = cell.Offset(0, 5).Value
                        .Range("D2").Offset(0 + lastrow, 0).Value = cell.Offset(0, 7).Value
                    End With
                End If
                ActiveWorkbook.Save
            Else
                'does not
                Set wb = Workbooks.Add(xlWBATWorksheet)
                With ActiveSheet
                    .Name = cell.Offset(0, 1).Value
                    .Range("A1").Value = "Levels"
                    .Range("B1").Value = "Chart_Value1"
                    .Range("C1").Value = "Chart_Value2"
                    .Range("D1").Value = "Chart_Value3"
                    .Range("A2").Value = cell.Offset(0, 2).Value
                    .Range("B2").Value = cell.Offset(0, 3).Value
                    .Range("C2").Value = cell.Offset(0, 5).Value
                    .Range("D2").Value = cell.Offset(0, 7).Value
                End With
                ActiveWorkbook.SaveAs f_Path & cell.Value & ".xls", 56
            End If
Skipper:
        Next
    End If
End With

For Each wb In Workbooks
    If ThisWorkbook.Name <> wb.Name Then
        For Each ws In wb.Worksheets
            With ws
                Set Rng = ws.UsedRange
                ws.Shapes.AddChart
            End With
        Next
        wb.Close True
    End If
Next

End Sub

Function IsWorkBookOpen(FileName As String)
    Dim ff As Long, ErrNo As Long

    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0

    Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function

Answer 2

以下代码将解析前两列中的数据，为第一列中的每个唯一单元格值创建工作簿，并为第二列中的每个唯一单元格值创建工作表。它最后添加xlColumnClustered 类型的图表并保存并关闭所有新书。源数据可以是un-sorted。

重要提示：根据您的情况更改常量TargetPath 和/或DataBookName, DataSheetName。

Option Explicit

' ---------------------------------------------------------------------------------------
' Results will be saved 'TargetPath' path. This path must be changed according to your PC
' Change this path:
Private Const TargetPath As String = "C:\Temp\Abdul_Shiyas\Results\"
' ---------------------------------------------------------------------------------------

' ---------------------------------------------------------------------------------------
' Expected data are contain in sheet named "Data" in wokbook with the name "Data.xlsx"
' This names can be changed according to your wokbook with data.
Private Const DataBookName As String = "Data.xlsx"
Private Const DataSheetName As String = "Data"
' ---------------------------------------------------------------------------------------

Private sourceBook As Workbook
Private sht As Worksheet
Private book As Workbook
Private books As Collection
Private header As Range
Private data As Range
Private criteria As Range
Private criteriaRow As Range
Private bookName As String
Private sheetName As String
Private newChart As Shape

Public Sub ParseToWorkbooks()

    ' Important:
    ' Data are expected to begin in cell "A1" and should not contain any blank rows or blank columns
    Set sourceBook = Workbooks(DataBookName)
    Set data = sourceBook.Worksheets(DataSheetName).Range("A1").CurrentRegion
    Set header = data.Rows(1)
    Set data = data.Offset(1, 0).Resize(data.Rows.Count - 1, data.Columns.Count)
    Set criteria = data.Resize(data.Rows.Count, 2)
    Set header = header.Offset(0, criteria.Columns.Count).Resize(1, header.Columns.Count - criteria.Columns.Count)
    Set books = New Collection

    For Each criteriaRow In criteria.Rows
        bookName = Trim(criteriaRow.Cells(1))
        sheetName = Trim(criteriaRow.Cells(2))

        ' get the book first
        Set book = Nothing
        On Error Resume Next
        Set book = books(bookName)
        On Error GoTo 0

        If book Is Nothing Then
            Set book = Workbooks.Add
            Application.DisplayAlerts = False
            book.SaveAs Filename:=TargetPath & bookName
            Application.DisplayAlerts = True
            books.Add book, bookName
        End If

        ' get the sheet then
        Set sht = Nothing
        On Error Resume Next
        Set sht = book.Worksheets(sheetName)
        On Error GoTo 0

        If sht Is Nothing Then
            Set sht = book.Worksheets.Add
            sht.Name = sheetName
            header.Copy Destination:=sht.Range("A1")
        End If

        ' paste data to the sheet
        criteriaRow.Cells(2).Offset(0, 1).Resize(1, data.Columns.Count - criteria.Columns.Count).Copy _
            Destination:=sht.Cells(sht.Rows.Count, 1).End(xlUp).Offset(1, 0)

    Next criteriaRow

    ' finally and chart, save and close each new book
    For Each book In books
        For Each sht In book.Worksheets
            If sht.Range("A1").Value <> "" Then
                Set newChart = sht.Shapes.AddChart
                newChart.Chart.SetSourceData Source:=sht.Range("A1").CurrentRegion
                newChart.Chart.ChartType = xlColumnClustered
            End If
        Next sht

        book.Close True
    Next book
End Sub