Имя пользователя:
Пароль:  
Помощь | Регистрация | Забыли пароль?  | Правила  

Компьютерный форум OSzone.net » Сфера Microsoft » Microsoft Office (Word, Excel, Outlook и т.д.) » 2010 - [решено] Как написать макрос разделения данных на категории

Ответить
Настройки темы
2010 - [решено] Как написать макрос разделения данных на категории

Пользователь


Сообщения: 73
Благодарности: 2

Профиль | Отправить PM | Цитировать


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

Отправлено: 17:36, 14-01-2021

 

Ветеран


Contributor


Сообщения: 26838
Благодарности: 7817

Профиль | Отправить PM | Цитировать


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

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

Отправлено: 21:49, 15-01-2021 | #11



Для отключения данного рекламного блока вам необходимо зарегистрироваться или войти с учетной записью социальной сети.

Если же вы забыли свой пароль на форуме, то воспользуйтесь данной ссылкой для восстановления пароля.


Ветеран


Contributor


Сообщения: 2189
Благодарности: 1351

Профиль | Отправить PM | Цитировать


Жаль выбрасывать в корзину, мой вариант, идея как у 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
Не быстро. Дождитесь сообщение "Сделано"

-------
Даже самая сложная проблема обязательно имеет простое, лёгкое для понимания, неправильное решение. Каждое решение плодит новые проблемы.


Последний раз редактировалось megaloman, 16-01-2021 в 18:22.

Это сообщение посчитали полезным следующие участники:

Отправлено: 00:05, 16-01-2021 | #12


Пользователь


Сообщения: 73
Благодарности: 2

Профиль | Отправить PM | Цитировать


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

Отправлено: 15:07, 16-01-2021 | #13


Ветеран


Contributor


Сообщения: 26838
Благодарности: 7817

Профиль | Отправить PM | Цитировать


Цитата 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
'=============================================================================
Ниже — должна быть картинка:
Это сообщение посчитали полезным следующие участники:

Отправлено: 15:56, 16-01-2021 | #14


Ветеран


Contributor


Сообщения: 2189
Благодарности: 1351

Профиль | Отправить PM | Цитировать


Вложения
Тип файла: zip я210116.zip
(1.2 Kb, 0 просмотров)

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

-------
Даже самая сложная проблема обязательно имеет простое, лёгкое для понимания, неправильное решение. Каждое решение плодит новые проблемы.


Отправлено: 18:31, 16-01-2021 | #15


Ветеран


Contributor


Сообщения: 26838
Благодарности: 7817

Профиль | Отправить PM | Цитировать


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

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

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

Отправлено: 19:07, 16-01-2021 | #16


Ветеран


Contributor


Сообщения: 2189
Благодарности: 1351

Профиль | Отправить PM | Цитировать


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

-------
Даже самая сложная проблема обязательно имеет простое, лёгкое для понимания, неправильное решение. Каждое решение плодит новые проблемы.


Отправлено: 19:18, 16-01-2021 | #17


Аватара для yurfed

Ветеран


Сообщения: 19060
Благодарности: 2935

Профиль | Отправить PM | Цитировать


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

-------
Мнение большинства людей всегда ошибочно, ибо большинство людей - идиоты.
~ Эдгар Аллан По ~


Отправлено: 20:21, 16-01-2021 | #18


Ветеран


Contributor


Сообщения: 2189
Благодарности: 1351

Профиль | Отправить PM | Цитировать


Изображения
Тип файла: png я210118.png
(46.5 Kb, 3 просмотров)
Вложения
Тип файла: txt я210118.vbs.txt
(3.0 Kb, 1 просмотров)

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) и картинку с результатом прикрепляю.

-------
Даже самая сложная проблема обязательно имеет простое, лёгкое для понимания, неправильное решение. Каждое решение плодит новые проблемы.


Последний раз редактировалось megaloman, 18-01-2021 в 18:51.


Отправлено: 18:42, 18-01-2021 | #19


Ветеран


Contributor


Сообщения: 26838
Благодарности: 7817

Профиль | Отправить PM | Цитировать


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

Отправлено: 19:27, 18-01-2021 | #20



Компьютерный форум OSzone.net » Сфера Microsoft » Microsoft Office (Word, Excel, Outlook и т.д.) » 2010 - [решено] Как написать макрос разделения данных на категории

Участник сейчас на форуме Участник сейчас на форуме Участник вне форума Участник вне форума Автор темы Автор темы Шапка темы Сообщение прикреплено

Похожие темы
Название темы Автор Информация о форуме Ответов Последнее сообщение
VBA - Помогите написать макрос в Excel, экспорт данных из Excel в Word. E.v.g Программирование и базы данных 7 03-05-2018 22:18
2010 - как написать vba формулу для обсчета данных r-studio Microsoft Office (Word, Excel, Outlook и т.д.) 3 12-03-2013 21:17
2003/XP/2000 - [решено] Excel: Написать маленький макрос anatoly_neo Microsoft Office (Word, Excel, Outlook и т.д.) 8 11-03-2010 17:56
CMD/BAT - как написать цикл с проверкой вводимых данных? angelada89 Скриптовые языки администрирования Windows 4 07-03-2010 14:42
Простой макрос. Excel. Не могу написать. prosims Программирование и базы данных 5 07-05-2007 09:11




 
Переход