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

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

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 · Отправлено: **00:05, 16-01-2021** | #12

Жаль выбрасывать в корзину, мой вариант, идея как у 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 · Отправлено: **15:07, 16-01-2021** | #13

Цитата Iska:

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

У Вас не открывается скрытый текст.
megaloman, Ваш вариант тоже посмотрю. Чем больше вариантов, тем быстрее в сравнении освою VBA .

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

Цитата 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 · Отправлено: **18:31, 16-01-2021** | #15

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

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

megaloman, ну, идея-то с фильтрацией:

Цитата megaloman:

наложите фильтр и копируйте отфильтрованные данные на другие листы. »

была Вашей.

Цитата megaloman:

Вариант Iska работает в 5-10 раз быстрее. »

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

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

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

Iska, А я пошел у Вас на поводу, и отталкивался от сортировки.

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

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

Цитата Iska:

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

Да, так и есть.

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

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 · Отправлено: **19:27, 18-01-2021** | #20

Цитата megaloman:

png я210118.png »

У меня секунд сорок конвертируется при открытии из формата Office 2007+ в формат Office 2003-

. Остальное проходит достаточно быстро.