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

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

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

每个工作表都包含图中的值。 其实我想用三个系列做一个图表。 因此，我必须在每张工作表中的列'levels'，'chart_vlaue_1'，'chart_vlaue_2'，'chart_vlaue_3'中创build数据表。 另外我想在每个工作表中生成图表。 请帮我创build一个示例图表。 我会努力的。 请帮帮我。

Answer 1

下面的代码将parsing前两列中的数据为第一列中的每个唯一单元值创build工作簿，并为第二列中的每个唯一单元格值创build工作簿。 它最后添加了xlColumnClusteredtypes的图表，并保存并closures了所有的新书。 源数据可以是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 

Answer 2

请在下面尝试，下面应该将您的数据分类到正确的工作表/工作簿，并为每个工作表创build一个图表。 f_Path是您将要保存这些文件的文件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