[решено] Как написать макрос разделения данных на категории

[Elizavetta]

Помогите, пожалуйста, у меня есть данные. прикрепила эксель .
со столбца А по J находится общая таблица. Мне из нее надо получить несколько таблиц для каждого дерева. Т.е. каждое дерево с его данными с A по J
вывести в отдельную табличку. Со столбца М по АК я показала пример. Сейчас я это делаю руками и очень тяжело. Особенно если огромное множество деревьев.
Если несложно помогите пожалуйста.

[megaloman]

Elizavetta, Вы владеете фильтром? Загрузите csv в Excel, наложите фильтр и копируйте отфильтрованные данные на другие листы. Пример прилагаю, иначе нужен макрос.

[okshef]

И сводные таблицы никто не отменял. Хоть десяток их сделайте

[Iska]

А я бы тупо просто отсортировал :). Хотя, если действительно «множество» — таки написал бы макрос.

[megaloman]

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

[Elizavetta]

megaloman, тут csv для маленького примера ,а в жизни будет xlsx

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

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

[Elizavetta]

Iska, если бы было мало деревьев, я бы сама руками:)
а тут может быть сотни. Поэтому и попросили помочь по возможности, конечно)

[Iska]

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

[Elizavetta]

Iska, сделаю.

[Elizavetta]

Iska, вот на ЯДиск выложила
https://yadi.sk/d/MQZfynlUO0OSFA

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

[Iska]

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. Спустя некоторое время Вы должны получить эту Рабочую книгу с несколькими новыми Рабочими листами, согласно уникальных данных из третьего столбца Рабочего листа «исходные данные», наподобие:
https://i.imgur.com/SHZFPTL.png
Дальше Вы можете поступать с этой открытой Рабочей книгой по своему усмотрению.

[megaloman]

Жаль выбрасывать в корзину, мой вариант, идея как у 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]

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

[Iska]

У Вас не открывается скрытый текст. »
Либо что-то у Вас блокирует исполнение скриптов на данной странице, либо недоступен адрес 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
'=============================================================================

Ниже — должна быть картинка:
https://i.imgur.com/SHZFPTL.png

[megaloman]

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

[Iska]

megaloman, ну, идея-то с фильтрацией:
наложите фильтр и копируйте отфильтрованные данные на другие листы. »
была Вашей.

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

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

[megaloman]

Iska, А я пошел у Вас на поводу, и отталкивался от сортировки. :) Думаю, какой вариант не используй, время вполне приемлемо.

[yurfed]

нет какого-нибудь исключающего, «вычетающего» метода — какого-нибудь .InterExclude() »
Да, так и есть.

[megaloman]

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]

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