Question

我有一个包含单个工作表的工作簿，如下所示。 enter image description here

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

每个工作表都包含图片中的值。其实我想制作一个有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

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

2 个答案: