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

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

vba excel

使用Excel VBA将单个工作簿拆分为包含多个工作表的多个工作簿,vba,excel,Vba,Excel,我有一份工作表，如下所示。我想根据其中的值将其拆分为许多工作簿，其中包含许多工作表。我想根据第1列的“n”唯一值制作“n”个工作簿，如图所示。我想根据第2列的“m”唯一值制作“m”工作表，如图所示。每个工作表包含如图所示的值。实际上我想用3个系列做一个图表。因此，我必须制作如图所示的数据表，每个工作表中有“级别”、“图表1”、“图表2”、“图表3”列。我还想在每个工作表中生成图表。请帮我创建一个示例图表。我会努力的。请帮帮我。试试下面，下面应该将您的数据分类到正确的工作表/工作

我有一份工作表，如下所示。

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

每个工作表包含如图所示的值。实际上我想用3个系列做一个图表。因此，我必须制作如图所示的数据表，每个工作表中有“级别”、“图表1”、“图表2”、“图表3”列。我还想在每个工作表中生成图表。请帮我创建一个示例图表。我会努力的。

请帮帮我。

试试下面，下面应该将您的数据分类到正确的工作表/工作簿中，并为每个工作表创建一个图表。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

Sub-main（）
暗f_路径
f_Path=“C:\”'保存文件的文件路径
使用ActiveSheet“在ActiveSheet上运行”
如果.Cells（2，1）.Value为“”，则如果A2不为空
对于.Range（“A2:”&.Range（“A2”）.End（xlDown.Address）中的每个单元格
如果Dir（f_Path&cell.Value&“.xls”）“”则
“存在
如果是工作簿打开（f_路径和cell.Value&“.xls”），则
“开
其他的
GoTo Skipper'未打开
如果结束
工作簿（cell.Value和“.xls”）。激活
出错时继续下一步
图纸（单元格偏移量（0，1）.值）。选择
如果错误号为0，则
Worksheets.Add（）.Name=cell.Offset（0，1）.Value
如果结束
错误转到0
lastrow=ActiveSheet.Range（“A1”）.End（xlDown）.第1行
如果lastrow=1048575，则“第一次
使用ActiveSheet
.Range（“A1”）.Value=“Levels”
.Range（“B1”）.Value=“图表值1”
.Range（“C1”）.Value=“图表值2”
.Range（“D1”）.Value=“图表值3”
.范围（“A2”）.值=单元偏移量（0,2）.值
.范围（“B2”）.值=单元偏移量（0,3）.值
.范围（“C2”）.值=单元偏移量（0,5）.值
.范围（“D2”）.值=单元格偏移量（0,7）.值
以
其他的
使用ActiveSheet
.Range（“A2”）.Offset（0+lastrow，0）。Value=单元格。Offset（0，2）。Value
.Range（“B2”）.Offset（0+lastrow，0）。Value=单元格。Offset（0，3）。Value
.Range（“C2”）.Offset（0+lastrow，0）。值=单元格。Offset（0，5）。值
.Range（“D2”）.Offset（0+lastrow，0）.Value=cell.Offset（0，7）.Value
以
如果结束
活动工作簿。保存
其他的
”“没有
设置wb=Workbooks.Add（xlWBATWorksheet）
使用ActiveSheet
.Name=单元格.Offset（0,1）.Value
.Range（“A1”）.Value=“Levels”
.Range（“B1”）.Value=“图表值1”
.Range（“C1”）.Value=“图表值2”
.Range（“D1”）.Value=“图表值3”
.范围（“A2”）.值=单元偏移量（0,2）.值
.范围（“B2”）.值=单元偏移量（0,3）.值
.范围（“C2”）.值=单元偏移量（0,5）.值
.范围（“D2”）.值=单元格偏移量（0,7）.值
以
ActiveWorkbook.SaveAs f_路径和单元格.Value和“.xls”，56
如果结束
船长：
下一个
如果结束
以
对于工作簿中的每个wb
如果此工作簿名为wb.Name，则
对于wb.工作表中的每个ws
与ws
设置Rng=ws.UsedRange
ws.Shapes.AddChart
以
下一个
wb.Close为真
如果结束
下一个
端接头
函数IsWorkBookOpen（文件名为字符串）
长时间调暗ff，长时间调暗ErrNo
出错时继续下一步
ff=FreeFile（）
打开输入锁的文件名，读取为#ff
关闭ff
ErrNo=Err
错误转到0
选择案例错误号
案例0:IsWorkBookOpen=False
案例70:IsWorkBookOpen=True
案例：错误ErrNo
结束选择
端函数

以下代码将解析前两列中的数据，为第一列中的每个唯一单元格值创建工作簿，并为第二列中的每个唯一单元格值创建工作表。它最后添加类型为

xlcolumn

的图表，并保存和关闭所有新书。源数据可以

取消排序

重要：根据您的条件更改常量

TargetPath

和/或

DataBookName、DataSheetName

选项显式
' ---------------------------------------------------------------------------------------
'结果将保存在'TargetPath'路径中。必须根据您的电脑更改此路径
'更改此路径：
Private Const TargetPath As String=“C:\Temp\Abdul\u Shiyas\Results”
' ---------------------------------------------------------------------------------------
' ---------------------------------------------------------------------------------------
'预期数据包含在wokbook中名为“data.xlsx”的名为“data”的工作表中'
'可以根据您的wokbook和数据更改此名称。
Private Const DataBookName As String=“Data.xlsx”
Private Const DataSheetName As String=“Data”
' ---------------------------------------------------------------------------------------
作为工作簿的专用源代码手册
私人sht As工作表
作为工作簿的私人书籍
藏书
作为范围的私有标头
私有的
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