vba - 使用 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