![](/img/trans.png)
[英]Copying Data from Multiple Worksheets in Workbooks to Differing Worksheets in Separate Workbook - VBA Excel
[英]Split a single workbook into multiple workbooks containing multiple worksheets using Excel VBA
我有一個帶有單個工作表的工作簿,如下所示。
我想根據其中的值將其拆分為包含許多工作表的許多工作簿。 我想根據圖片中第1列的“ n”個唯一值來制作“ n”個工作簿。 我想根據圖片中第2列的“ m”個唯一值制作“ m”個工作表。
每個工作表都包含圖片中的值。 實際上,我想制作一個包含3個系列的圖表。 因此,我必須像在圖片中那樣在每個工作表中使用“級別”,“ chart_vlaue_1”,“ chart_vlaue_2”,“ chart_vlaue_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
下面的代碼將解析前兩列中的數據,為第一列中的每個唯一單元格值創建工作簿,為第二列中的每個唯一單元格值創建工作表。 最后,它將添加類型為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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.