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

Question

I have a workbook with single worksheet as given below.

I want to split it into many workbooks containing many worksheets according to the values in it. I want to make 'n' number of workbooks according to 'n' unique values of column 1 as in the picture. And I want to make 'm' worksheets according to 'm' unique values of column 2 as in the picture.

Each worksheet contains values as in the picture. Actually I want to make a chart with 3 series. So I have to make data table as in the picture with columns 'levels', 'chart_vlaue_1', 'chart_vlaue_2', 'chart_vlaue_3' in each worksheet. Also I want to generate charts in each of the worksheet. Please help me a create a sample chart. I will work on it. Please help me.

Answer 1

Try below, below should sort your data into the correct sheets/workbooks and create you a chart for each sheet. f_Path is the file path of where you will save these files. if the files already exist the code will SKIP THESE

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

The following code will parse the data in first two columns create workbooks for each unique cell value from first column and sheet for each unique cell value from second column. It finally adds charts of type xlColumnClustered and saves and closes all the new books. Source data can be un-sorted .

Important : change the constants TargetPath and/or DataBookName, DataSheetName according to your conditions.

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