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.
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
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.