Страницы: 1
RSS
Разделение листов книги на файлы по именам листов
 
Добрый вечер!

Есть книга 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)
Изменено: Stratcher - 22.03.2018 20:36:29
 
Вот тут есть код на копирование листа со всеми форматами в новую книгу и т.д.. Измените немного, делайте цикл по всем листам книги, из которой будете размножать листы, включите требуемое условие.
 
Не могу разобраться с массивом для хранения уникальных имён. Даже объявить толком не могу, хотя вроде делаю как положено.
Код
Dim Name(Worksheets.Count) as String
 
Сделал, делюсь кодом. Палками не бить, про оптимизацию речи даже не стояло.
Код
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
Изменено: Stratcher - 23.03.2018 07:49:01
 
Код
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
При необходимости можно отключить обновление экрана.
Изменено: Nordheim - 24.03.2018 11:14:20
"Все гениальное просто, а все простое гениально!!!"
 
Еще один вариант:
Код
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
 
Столько примеров, явно кому-нибудь пригодится)

Ещё, чтобы не плодить темы, как-то можно с помощью InputBox заполнить массив? Не по одному значению, а целиком в одной форме?
 
Stratcher, модераторы ругаться будут. Только не через VB InputBox, а через Application.InputBox. И не напрямую, а указав диапазон, который потом можно взять в массив.
Изменено: Anchoret - 23.03.2018 19:40:50
 
Цитата
Stratcher написал:
чтобы не плодить темы
А Вы считаете, что плодить вопросы в теме, которые к ней не относятся, это нормально?
Страницы: 1
Наверх