Есть книга Excel, в ней уйма листов. В названиях листов первая часть имени является названием класса, к примеру, 354А(группа1), 354А(группа2). Нужно разделить книгу на файлы, в которых будут листы с одинаковыми классами.
На питоне это реализуется очень просто, вот так. Суть кода элементарная как сам код - сперва формируем множество уникальных названий класса, путём взятие первых 4 символов из названия каждого листа, потом циклом сравниваем каждый класс именами листов, если название содержит класс, добавляем в книгу, в конце сохраняем книгу по имени класса. Собственно, на питоне это и работает, однако такой подход убивает всё оформление, что, увы, не подходит. Подскажите пожалуйста, как реализовать сей код на VBA?
Код
import pyexcel_xlsx as pe
from pyexcel_xlsx import save_data
from collections import OrderedDict
file = pe.get_data('2018.xlsx')
sheet_name = set()
for key in file.keys():
sheet_name.add(key[0:4].lower())
for name in sheet_name:
data = OrderedDict()
for key in file.keys():
if name in key.lower():
data.update({key:file[key]})
save_data('{}.xlsx'.format(name), data)
Вот тут есть код на копирование листа со всеми форматами в новую книгу и т.д.. Измените немного, делайте цикл по всем листам книги, из которой будете размножать листы, включите требуемое условие.
Сделал, делюсь кодом. Палками не бить, про оптимизацию речи даже не стояло.
Код
Sub Split():
Dim i As Integer
Dim j As Integer
Dim sheet_c As Integer
Dim sh_count As Integer
Dim name As String
Dim newWB As Workbook
Dim format As String
format = ".xlsx"
sh_count = ThisWorkbook.Worksheets.Count
Dim sh_name() As String
ReDim sh_name(1 To sh_count)
For i = 1 To sh_count
name = Mid(ThisWorkbook.Sheets(i).name, 1, 5)
sh_name(i) = name
Next
For i = 1 To sh_count
Set newWB = Workbooks.Add
sheet_c = 1
For j = 1 To sh_count
If sh_name(i) = Mid(ThisWorkbook.Sheets(j).name, 1, 5) Then
ThisWorkbook.Sheets(j).Copy newWB.Sheets(sheet_c)
sheet_c = sheet_c + 1
End If
Next
name = sh_name(i) & format
newWB.Application.DisplayAlerts = False
newWB.Sheets("Лист1").Delete
newWB.Sheets("Лист2").Delete
newWB.Sheets("Лист3").Delete
newWB.SaveAs (name)
newWB.Close
Next
End Sub
Sub Split()
Dim sht As Worksheet
Dim coll As New Collection, ikey
Dim book As Workbook, ibook As Workbook
Application.DisplayAlerts = False
Set book = ThisWorkbook
On Error Resume Next
For Each sht In ThisWorkbook.Worksheets
coll.Add Mid(sht.name, 1, 5), CStr(Mid(sht.name, 1, 5))
Next sht
On Error GoTo 0
For Each ikey In coll
Set ibook = Workbooks.Add(1)
ibook.SaveAs (book.Path & "\" & ikey & ".xlsx")
For Each sht In book.Worksheets
If ikey = Mid(sht.name, 1, 5) Then sht.Copy after:=ibook.Sheets(ibook.Sheets.Count)
Next sht
ibook.Worksheets(1).Delete
ibook.Close True
Next ikey
Application.DisplayAlerts = True
End Sub
При необходимости можно отключить обновление экрана.
Sub SaveCopySheets()
Dim newWB As Workbook, wbn$, oldWB As Workbook, arr()
Dim ClSh As Object, arr1(), arr2(), sh As Worksheet, a%, b%, c%
Set ClSh = CreateObject("Scripting.Dictionary")
Set oldWB = ThisWorkbook: wbn = oldWB.FullName
For Each sh In oldWB.Sheets
If Left$(sh.Name, 4) Like "####" Then
If Not ClSh.exists(Mid$(sh.Name, 5, 1)) Then
ReDim arr(1 To 2): arr(1) = 3: arr(2) = sh.Name
ClSh.Add Mid$(sh.Name, 5, 1), arr
Else
arr = ClSh.Item(Mid$(sh.Name, 5, 1)): ReDim Preserve arr(1 To arr(1))
arr(arr(1)) = sh.Name: arr(1) = arr(1) + 1: ClSh.Item(Mid$(sh.Name, 5, 1)) = arr
End If
End If
Next
arr1 = ClSh.keys(): arr2 = ClSh.items()
Application.DisplayAlerts = False
For a = 0 To ClSh.Count - 1
Set newWB = Workbooks.Add: c = newWB.Sheets.Count
For b = 2 To arr2(a)(1) - 1
Set sh = oldWB.Sheets(arr2(a)(b)): sh.Copy after:=newWB.Sheets(c)
Next
Do While c > 0: newWB.Sheets(c).Delete: c = c - 1: Loop
newWB.SaveAs Filename:=Left$(wbn, Len(wbn) - 4) & "_" & arr1(a) & ".xlsx", FileFormat:=xlOpenXMLWorkbook
newWB.Close
Next
Application.DisplayAlerts = True
End Sub
Sub iDictionary()
Dim book As Workbook, ibook As Workbook
Dim arr$(), ikey, skey, iDic As Object
Dim sht As Worksheet
Set iDic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set book = ThisWorkbook
For Each sht In book.Worksheets
iDic.Item(CStr(Mid(sht.Name, 1, 5))) = iDic.Item(CStr(Mid(sht.Name, 1, 5))) & sht.Name & "|"
Next sht
For Each ikey In iDic.keys
Set ibook = Workbooks.Add(1)
ibook.SaveAs (book.Path & "\" & ikey & ".xlsx")
arr = Split(iDic.Item(ikey), "|")
For Each skey In arr
If Len(skey) > 0 Then book.Worksheets(skey).Copy after:=ibook.Worksheets(ibook.Sheets.Count)
Next
ibook.Worksheets(1).Delete
ibook.Close True
Next ikey
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
"Все гениальное просто, а все простое гениально!!!"
На основе предыдущего кода, с учетом того, что можно копировать сразу несколько листов
Код
Sub SaveClasses()
Dim skey, iDic As Object, sht
Set iDic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
For Each sht In Sheets
skey = Trim(Left$(sht.name, 5))
iDic(skey) = iDic(skey) & vbTab & sht.name
Next sht
For Each skey In iDic.keys
Sheets(Split(Mid(iDic(skey), 2), vbTab)).Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & skey & ".xlsx"
ActiveWorkbook.Close 0
Next skey
Application.ScreenUpdating = True
End Sub
Stratcher, модераторы ругаться будут. Только не через VB InputBox, а через Application.InputBox. И не напрямую, а указав диапазон, который потом можно взять в массив.