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

Question

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

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

每个工作表都包含图片中的值。 实际上，我想制作一个包含3个系列的图表。 因此，我必须像在图片中那样在每个工作表中使用“级别”，“ 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