Жаль выбрасывать в корзину, мой вариант, идея как у Iska.
В скрипте надо прописать имя исходного файла. Можно сделать как у Iska, чтобы не прописывать.
В книге должен быть один исходный лист.
С вариантом Iska по времени не сравнивал
[spoiler]Код:
[/spoiler]
Код: Выделить всё
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
Не быстро. Дождитесь сообщение "Сделано"
Думаю, какой вариант не используй, время вполне приемлемо.