Компьютерный форум OSzone.net  

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)
-   Microsoft Office (Word, Excel, Outlook и т.д.) (http://forum.oszone.net/forumdisplay.php?f=115)
-   -   [решено] Как написать макрос разделения данных на категории (http://forum.oszone.net/showthread.php?t=347638)

Elizavetta 14-01-2021 17:36 2946201
Как написать макрос разделения данных на категории
 
Вложений: 1
Помогите, пожалуйста, у меня есть данные. прикрепила эксель .
со столбца А по J находится общая таблица. Мне из нее надо получить несколько таблиц для каждого дерева. Т.е. каждое дерево с его данными с A по J
вывести в отдельную табличку. Со столбца М по АК я показала пример. Сейчас я это делаю руками и очень тяжело. Особенно если огромное множество деревьев.
Если несложно помогите пожалуйста.

megaloman 14-01-2021 18:16 2946206
Вложений: 1
Elizavetta, Вы владеете фильтром? Загрузите csv в Excel, наложите фильтр и копируйте отфильтрованные данные на другие листы. Пример прилагаю, иначе нужен макрос.

okshef 14-01-2021 19:41 2946218
И сводные таблицы никто не отменял. Хоть десяток их сделайте

Iska 14-01-2021 19:44 2946219
А я бы тупо просто отсортировал :). Хотя, если действительно «множество» — таки написал бы макрос.

megaloman 15-01-2021 05:33 2946254
Elizavetta, уточните задачу. У Вас какой исходный файл: csv или xlsx, xls ... и что должно получиться в результате: несколько csv или xlsx.

Elizavetta 15-01-2021 13:10 2946287
megaloman, тут csv для маленького примера ,а в жизни будет xlsx

результат должен быть в этом же экселе
я там показала. т.е. для каждой породы своя табличка и они в этом же экселе идут друг за другом.

Макрос нужен, потому что я фильтром и не хочу вручную. Вот отсюда и родилась просьба о макросе. Т.е. то что вы сделали фильтром мне бы макросом автоматом

Elizavetta 15-01-2021 13:41 2946294
Iska, если бы было мало деревьев, я бы сама руками:)
а тут может быть сотни. Поэтому и попросили помочь по возможности, конечно)

Iska 15-01-2021 15:25 2946312
Elizavetta, давайте тогда так: упакуйте реальный файл в архив, каковой приложите к сообщению, либо выложите на облако или вменяемый обменик. Расскажите, что значит «вывести в отдельную табличку» — на новый Рабочий лист, в новую Рабочую книгу, и как их правильно именовать (в том варианте, который Вы выберете).

Elizavetta 15-01-2021 17:41 2946334
Iska, сделаю.

Elizavetta 15-01-2021 18:12 2946340
Iska, вот на ЯДиск выложила
https://yadi.sk/d/MQZfynlUO0OSFA

на первом листе то что было, на втором я разделила по породам сама.
Т.е. вот так должно быть на выходе.
т.е отфильтровала березу, скопировала, ее данные, вставила. Тоже самое с другим деревом
в разложенных данных есть колонка кластер, на нее не обращайте внимание, считайте что ее нет. Просто эта версия готова для отчета. Если будет проще, удалите все колонки кластер со второго листа, если сильно мешать будет. Она появляется только тогда как я все разложила сама, обработала и проставила номер кластера. В макросе ее учитывать не надо.

Iska 15-01-2021 21:49 2946357
Elizavetta, предлагаю немного другой вариант.

Сохраните код в файл с расширением .vbs:
Скрытый текст
Код:
Option Explicit

Const xlFilterCopy = 2


Dim strSourceFile

Dim objFSO

Dim objExcel
Dim objThisWorksheet
Dim objNewWorksheet

Dim objRange

Dim objDictionary
Dim arrKeys
Dim i


If WScript.Arguments.Count = 1 Then
        Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
       
        strSourceFile = objFSO.GetAbsolutePathName(WScript.Arguments.Item(0))
       
        If objFSO.FileExists(strSourceFile) Then
                Set objExcel        = WScript.CreateObject("Excel.Application")
                Set objThisWorksheet = objExcel.Workbooks.Open(strSourceFile).Worksheets.Item("исходные данные")
               
                With objThisWorksheet
                        Set objDictionary = WScript.CreateObject("Scripting.Dictionary")
                       
                        Set objNewWorksheet = .Parent.Worksheets.Add()
                       
                        .UsedRange.Columns(3).Cells.AdvancedFilter xlFilterCopy, , objNewWorksheet.Cells(1), True
                       
                        For i = 2 To objNewWorksheet.UsedRange.Rows.Count
                                objDictionary.Add objNewWorksheet.Cells(i, 1).Value, 0
                        Next
                       
                        objExcel.DisplayAlerts = False
                        objNewWorksheet.Delete
                        objExcel.DisplayAlerts = True
                       
                        Set objNewWorksheet = Nothing
                       
                       
                        arrKeys = objDictionary.Keys
                       
                        For i = UBound(arrKeys) To LBound(arrKeys) Step -1
                                .UsedRange.AutoFilter 3, arrKeys(i)
                                CopyRange2NewWorksheet .Parent.Worksheets.Add(, objThisWorksheet), arrKeys(i), .UsedRange
                        Next
                       
                        objDictionary.RemoveAll
                        Set objDictionary = Nothing
                       
                        .ShowAllData
                        .AutoFilterMode = False
                       
                        .Select
                End With
               
                objExcel.Visible = True
               
                Set objThisWorksheet = Nothing
                Set objExcel        = Nothing
        Else
                WScript.Echo "Can't find source file [" & strSourceFile & "]."
                WScript.Quit 2
        End If
       
        Set objFSO = Nothing
Else
        WScript.Echo "Usage: cscript.exe //nologo """ & WScript.ScriptName & """ <Source file>"
        WScript.Quit 1
End If

WScript.Quit 0
'=============================================================================

'=============================================================================
Sub CopyRange2NewWorksheet(objNewWorksheet, strName, objRange)
        With objNewWorksheet
                objRange.Copy .Cells(1)
                .Name = strName
                .Columns.AutoFit
        End With
End Sub
'=============================================================================

Затем просто перетащите на него Ваш файл с Рабочей книгой Excel. Спустя некоторое время Вы должны получить эту Рабочую книгу с несколькими новыми Рабочими листами, согласно уникальных данных из третьего столбца Рабочего листа «исходные данные», наподобие:
Скрытый текст

Дальше Вы можете поступать с этой открытой Рабочей книгой по своему усмотрению.

megaloman 16-01-2021 00:05 2946367
Жаль выбрасывать в корзину, мой вариант, идея как у Iska.
В скрипте надо прописать имя исходного файла. Можно сделать как у Iska, чтобы не прописывать.
В книге должен быть один исходный лист.
С вариантом Iska по времени не сравнивал
Код:
InXls = "Z:\Box_In\реальные данные исходный лист.xlsx"    'имя исходного Excel-файла
Col1 = "A"                          'Первая колонка данных
Col2 = "J"                          'Последняя колонка данных

Row1 = 1                            'Последняя строка шапки
Csort = "C"                        'Колонка с сортируемыми данными

With WScript.Arguments
    If .Count > 0 Then InXls = .Item(0)
End With

If Not CreateObject("Scripting.FileSystemObject").FileExists(InXls) Then
            MsgBox "Файл:" + vbCrLf + InXls + vbCrLf + "не найден"
            WScript.Quit 1
End If

TBegin = Timer

Set xls = CreateObject("Excel.Application")
With xls
    .Visible = True  'True  ' False
    .Workbooks.Open InXls
    InBook = .ActiveWorkbook.Name
    InList = .Workbooks(InBook).ActiveSheet.Name
    .Workbooks(InBook).Activate
    .Columns(Col1 + ":" + Col2).EntireColumn.AutoFit
    Head = .Range(Col1 + CStr(Row1) + ":" + Col2 + CStr(Row1))
End With

TLoad = Timer
Row2 = xls.Workbooks(InBook).Worksheets(InList).Range(Csort + CStr(Row1 + 1)).End(-4121).Row

With xls.Workbooks(InBook).Worksheets(InList).Sort
    .SortFields.Clear
    .SortFields.Add xls.Range(Csort + CStr(Row1 + 1) + ":" + Csort + CStr(Row2)), 0, 1, 0
    .SetRange xls.Range(Col1 + CStr(Row1) + ":" + Col2 + CStr(Row2))
    .Header = 1
    .MatchCase = False
    .Orientation = 1
    .SortMethod = 1
    .Apply
End With

TSort = Timer
i1 = Row1 + 1
i2 = i1
NameList = xls.Range(Csort + CStr(i1))

For I = Row1 + 1 To Row2
    If NameList <> xls.Range(Csort + CStr(I)) Then
        Call Migrate(xls, Col1, i1, Col2, i2, NameList, Row1, InList, Head)
        i1 = I
        NameList = xls.Range(Csort + CStr(I))
    End If
    i2 = I
Next

Call Migrate(xls, Col1, i1, Col2, i2, NameList, Row1, InList, Head)

xls.CutCopyMode = False
xls.Visible = True  ' False

MsgBox "Сделано=" + CStr(Timer - TBegin) + " сек." + vbCrLf + "Загрузка=" + CStr(TLoad - TBegin) + vbCrLf + "Сортировка=" + CStr(TSort - TLoad)

Sub Migrate(xls, Col1, i1, Col2, i2, NameList, Row1, InList, Head)
        With xls
            .Range(Col1 + CStr(i1) + ":" + Col2 + CStr(i2)).Copy
       
            NCount = .Sheets.Count
            .Sheets.Add , .Worksheets(NCount)
            .Sheets(NCount + 1).Name = NameList
            .Range(Col1 + CStr(Row1 + 1)).Select
            .ActiveSheet.Paste
            .Range(Col1 + CStr(Row1) + ":" + Col2 + CStr(Row1)) = Head
            .Columns(Col1 + ":" + Col2).EntireColumn.AutoFit
            .Range("A1").Select
       
            .Worksheets(InList).Activate
        End With
End Sub
Не быстро. Дождитесь сообщение "Сделано"

Elizavetta 16-01-2021 15:07 2946413
Цитата:
Цитата Iska
Затем просто перетащите на него Ваш файл с Рабочей книгой Excel. Спустя некоторое время Вы должны получить эту Рабочую книгу с несколькими новыми Рабочими листами, согласно уникальных данных из третьего столбца Рабочего листа «исходные данные», наподобие: »
У Вас не открывается скрытый текст.
megaloman, Ваш вариант тоже посмотрю. Чем больше вариантов, тем быстрее в сравнении освою VBA .

Iska 16-01-2021 15:56 2946415
Цитата:
Цитата Elizavetta
У Вас не открывается скрытый текст. »
Либо что-то у Вас блокирует исполнение скриптов на данной странице, либо недоступен адрес https://i.imgur.com.

Ну, давайте попробуем отобразить так (надеюсь, нас простят модераторы).

Ниже код:
Код:
Option Explicit

Const xlFilterCopy = 2


Dim strSourceFile

Dim objFSO

Dim objExcel
Dim objThisWorksheet
Dim objNewWorksheet

Dim objRange

Dim objDictionary
Dim arrKeys
Dim i


If WScript.Arguments.Count = 1 Then
        Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
       
        strSourceFile = objFSO.GetAbsolutePathName(WScript.Arguments.Item(0))
       
        If objFSO.FileExists(strSourceFile) Then
                Set objExcel        = WScript.CreateObject("Excel.Application")
                Set objThisWorksheet = objExcel.Workbooks.Open(strSourceFile).Worksheets.Item("исходные данные")
               
                With objThisWorksheet
                        Set objDictionary = WScript.CreateObject("Scripting.Dictionary")
                       
                        Set objNewWorksheet = .Parent.Worksheets.Add()
                       
                        .UsedRange.Columns(3).Cells.AdvancedFilter xlFilterCopy, , objNewWorksheet.Cells(1), True
                       
                        For i = 2 To objNewWorksheet.UsedRange.Rows.Count
                                objDictionary.Add objNewWorksheet.Cells(i, 1).Value, 0
                        Next
                       
                        objExcel.DisplayAlerts = False
                        objNewWorksheet.Delete
                        objExcel.DisplayAlerts = True
                       
                        Set objNewWorksheet = Nothing
                       
                       
                        arrKeys = objDictionary.Keys
                       
                        For i = UBound(arrKeys) To LBound(arrKeys) Step -1
                                .UsedRange.AutoFilter 3, arrKeys(i)
                                CopyRange2NewWorksheet .Parent.Worksheets.Add(, objThisWorksheet), arrKeys(i), .UsedRange
                        Next
                       
                        objDictionary.RemoveAll
                        Set objDictionary = Nothing
                       
                        .ShowAllData
                        .AutoFilterMode = False
                       
                        .Select
                End With
               
                objExcel.Visible = True
               
                Set objThisWorksheet = Nothing
                Set objExcel        = Nothing
        Else
                WScript.Echo "Can't find source file [" & strSourceFile & "]."
                WScript.Quit 2
        End If
       
        Set objFSO = Nothing
Else
        WScript.Echo "Usage: cscript.exe //nologo """ & WScript.ScriptName & """ <Source file>"
        WScript.Quit 1
End If

WScript.Quit 0
'=============================================================================

'=============================================================================
Sub CopyRange2NewWorksheet(objNewWorksheet, strName, objRange)
        With objNewWorksheet
                objRange.Copy .Cells(1)
                .Name = strName
                .Columns.AutoFit
        End With
End Sub
'=============================================================================
Ниже — должна быть картинка:

megaloman 16-01-2021 18:31 2946431
Вложений: 1
Elizavetta, Слегка доработал свой скрипт: можно явно указать имя файла в скрипте, а можно в проводнике на скрипт или его значок затягивать обрабатываемый файл. На всякий случай заархивированный файл со скриптом прилагаю.
Вариант Iska работает в 5-10 раз быстрее.

Iska 16-01-2021 19:07 2946437
megaloman, ну, идея-то с фильтрацией:
Цитата:
Цитата megaloman
наложите фильтр и копируйте отфильтрованные данные на другие листы. »
была Вашей.

Цитата:
Цитата megaloman
Вариант Iska работает в 5-10 раз быстрее. »
Тут хоть обоптимизируйся — толку мало будет: нужна скорость — пользуй ADO. Но решил, что не стоит заморачиваться, поскольку у меня здесь Office 2003, а под него другой драйвер нужен, нежели под авторский Office более новых версий. Посему не стал выпендриваться.

Я постоянно жалею, что, наряду с методами Union() и Intersect(), нет какого-нибудь исключающего, «вычетающего» метода — какого-нибудь .InterExclude(), исключающего часть диапазона. Очень не хватает. Самописный код, реализующий подобный функционал, конечно, работает, но уж очень медленно.

megaloman 16-01-2021 19:18 2946440
Iska, А я пошел у Вас на поводу, и отталкивался от сортировки. :) Думаю, какой вариант не используй, время вполне приемлемо.

yurfed 16-01-2021 20:21 2946449
Цитата:
Цитата Iska
нет какого-нибудь исключающего, «вычетающего» метода — какого-нибудь .InterExclude() »
Да, так и есть.

megaloman 18-01-2021 18:42 2946746
Вложений: 2
Iska, Elizavetta, Мне кажется, мы занимаемся не тем: откуда в Excel попадают данные? Вероятно, выгружаются из какой-то базы. И что такое отчет, какова его форма. Надо иметь какой-то отчетный бланк с красивыми заголовочками и т д. Не вижу, чем полученный нашими скриптами отчет (то ли на основе создания листов, то ли на основе группировки) лучше простого применения фильтра.
Надо на этапе выгрузки в Excel формировать отчет, на нужных листах Excel, а не изобретать костыли.
В качестве развлечения, наваял еще вариант не на основе создания листов, а на основе группировки данных.
Код:
InXls = "Z:\Box_In\реальные данные исходный лист.xlsx"    'имя исходного Excel-файла
' InXls = "Z:\Box_In\я210115.xlsx"    'имя исходного Excel-файла
Col1 = "A"                          'Первая колонка данных
Col2 = "J"                          'Последняя колонка данных

Row1 = 1                            'Последняя строка шапки
Csort = "C"                        'Колонка с сортируемыми данными
Csum1 = "B"                        'Колонка с суммой 1
Csum2 = "D"                        'Колонка с суммой 2
Csum3 = "E"                        'Колонка с суммой 3
Csum4 = "F"                        'Колонка с суммой 4

With WScript.Arguments
    If .Count > 0 Then InXls = .Item(0)
End With

If Not CreateObject("Scripting.FileSystemObject").FileExists(InXls) Then
        MsgBox "Файл:" + vbCrLf + InXls + vbCrLf + "не найден"
        WScript.Quit 1
End If

TBegin = Timer

Set xls = CreateObject("Excel.Application")
With xls
    .Visible = True  'True  ' False
    .Workbooks.Open InXls
    InBook = .ActiveWorkbook.Name
    InList = .Workbooks(InBook).ActiveSheet.Name
    .Workbooks(InBook).Activate
    .Columns(Col1 + ":" + Col2).EntireColumn.AutoFit
    Head = .Range(Col1 + CStr(Row1) + ":" + Col2 + CStr(Row1))
End With

TLoad = Timer
Row2 = xls.Workbooks(InBook).Worksheets(InList).Range(Csort + CStr(Row1 + 1)).End(-4121).Row

With xls.Workbooks(InBook).Worksheets(InList).Sort
    .SortFields.Clear
    .SortFields.Add xls.Range(Csort + CStr(Row1 + 1) + ":" + Csort + CStr(Row2)), 0, 1, 0
    .SetRange xls.Range(Col1 + CStr(Row1) + ":" + Col2 + CStr(Row2))
    .Header = 1
    .MatchCase = False
    .Orientation = 1
    .SortMethod = 1
    .Apply
End With

TSort = Timer
i1 = Row1 + 1
NameList = xls.Range(Csort + CStr(i1))

With xls.Workbooks(InBook).Worksheets(InList)
    i = i1
    Do
        If NameList <> xls.Range(Csort + CStr(i)) Then
            .Rows(CStr(i)).Insert -4162, 0
            .Range(Col1 + CStr(i)) = .Range(Csort + CStr(i - 1))
            .Range(Csort + CStr(i)) = .Range(Csort + CStr(i - 1))
            .Rows(CStr(i1) + ":" + CStr(i - 1)).Rows.Group
            .Range(Csum1 + CStr(i)) = "=SUM(" + Csum1 + CStr(i1) + ":" + Csum1 + CStr(i - 1) + ")"
            .Range(Csum2 + CStr(i)) = "=SUM(" + Csum2 + CStr(i1) + ":" + Csum2 + CStr(i - 1) + ")"
            .Range(Csum3 + CStr(i)) = "=SUM(" + Csum3 + CStr(i1) + ":" + Csum3 + CStr(i - 1) + ")"
            .Range(Csum4 + CStr(i)) = "=SUM(" + Csum4 + CStr(i1) + ":" + Csum4 + CStr(i - 1) + ")"
            i = i + 1
            i1 = i
            NameList = .Range(Csort + CStr(i))
            If Len(Trim(NameList)) = 0 Then Exit Do
        End If
        i = i + 1
    Loop
   
    .Outline.ShowLevels 1
    .Range("A1").Select
End With

xls.Visible = True  ' False

MsgBox "Сделано=" + CStr(Timer - TBegin) + " сек." + vbCrLf _
        + "Загрузка=" + CStr(TLoad - TBegin) + vbCrLf _
        + "Сортировка=" + CStr(TSort - TLoad) + vbCrLf _
        + "Группировка=" + CStr(Timer - TSort)

Скрипт (переименуйте txt в vbs) и картинку с результатом прикрепляю.

Iska 18-01-2021 19:27 2946756
Цитата:
Цитата megaloman
png я210118.png »
У меня секунд сорок конвертируется при открытии из формата Office 2007+ в формат Office 2003- :). Остальное проходит достаточно быстро.


Время: 15:40.

Время: 15:40.
© OSzone.net 2001-