как сгруппировать строки в Excel?

[Hugo121]

Да, действительно , спасибо. Но если в итоге делать код в третьем файле, то можно имена листов вообще не анализировать, наверняка в приходящей справке лишнего не будет.
Пока исправил текущий код.
Ну так если уже вручную перелопачено - можно проверить. Себя и коды.
Хотя я себе конкурентов не вижу

[KL (XL)]

Вот процедура для создания списка сумм по кодам, который у меня бегает достаточно быстро. Может, не так как код Hugo121, но глазу это незаметно и, к тому же, он позволяет ручные манипуляции с отчетом (особенно не слишком посвященным в VBA)

PHP код:

Option Explicit

Sub CreateList()
    Dim pc As PivotCache
    Dim pt As PivotTable
    Dim pi As PivotItem
    Dim ws As Worksheet
    Dim wsRep As Worksheet
    Dim arrPages()
    Dim strDest As String
    Dim t As Double
    
    ReDim arrPages(0)
    Application.ScreenUpdating = False
    With ThisWorkbook
        Set wsRep = .Worksheets("Sheet1")
        wsRep.Cells.Clear
        t = Timer
        For Each ws In .Worksheets
            If ws.Name Like "Документ (*)" Then
                With ws
                    arrPages(UBound(arrPages)) = _
                        Array( _
                        .Range(.[A8], .Cells(.Rows.Count, 1).End(xlUp).Offset(, 13)).Address(, , xlR1C1, -1), _
                        ws.Name _
                        )
                End With
                ReDim Preserve arrPages(UBound(arrPages) + 1)
            End If
        Next ws
        ReDim Preserve arrPages(UBound(arrPages) - 1)
        
        Set pc = ActiveWorkbook.PivotCaches.Add( _
            SourceType:=xlConsolidation, _
            SourceData:=arrPages)
        
        strDest = wsRep.Range("A1").Address(, , xlR1C1, True)
        
        Set pt = pc.CreatePivotTable( _
            TableDestination:=strDest, _
            TableName:="Отчет")
    End With
    
    With pt
        .DataPivotField.PivotItems(1).Position = 1
        With .DataFields(1)
            .Caption = "Суммы по кодам"
            .Function = xlSum
        End With
        .PivotFields(1).Caption = "Список Кодов"
        .PivotFields(4).Caption = "Документ"
        With .PivotFields(2)
            .Caption = "Поле"
            For Each pi In .PivotItems
                If pi.Caption <> "13" Then pi.Visible = False
            Next pi
        End With
        .RowGrand = False
        .ColumnGrand = False
    End With
    Application.ScreenUpdating = True
    MsgBox Timer - t
End Sub 


протестировано:
Win 7 Ultimate EN, MSO 2010 Pro EN
Win XP Pro EN, MSO 2003 Pro EN MUI RU

[KL (XL)]

Сообщение от Hugo121

Да, действительно , спасибо. Но если в итоге делать код в третьем файле, то можно имена листов вообще не анализировать, наверняка в приходящей справке лишнего не будет.
Пока исправил текущий код.
Ну так если уже вручную перелопачено - можно проверить. Себя и коды.
Хотя я себе конкурентов не вижу

У меня в Win 7, MSO2010

строка

PHP код:

   Set objDialog = CreateObject("UserAccounts.CommonDialog") 


выдает ошибку:

-------------------------------------
Run-time error '429'
Activex component can't create object
-------------------------------------

не смотря на присутствие в системе comdlg32.dll

[biv]

Сообщение от IgorGO

biv, а Вы переживали...
то все молчали по очереди, то набросали разных вариантов.
...А отчет небось пришлось вручную колбасить?

Вы правы, колбасили вручную. Но.. я сейчас пойду в отпуск, съезжу в гости (тк опять месяц впереди) и сяду просмотрю все варианты. Пока бегло просмотрела..... ну вы и умные ребята!!!!!!!..... а для меня это темный лес(но постараюсь пробраться сквозь дебри) .
Спасибо всем огромное!!!!!!!

[Hugo121]

KL (XL), там просто суммы по кодам мало, там сперва надо эти коды частично изменить. И кстати Ваш код тоже у меня не идёт - сперва "Лист1", а затем .DataPivotField.PivotItems(1).Posit ion = 1.
А UserAccounts.CommonDialog можно заменить, сейчас не помню чем, но можно
Ну и ведь можно выбрать файл и привычным всем диалогом, который правда у меня на 2000 не работает, поэтому я им не пользуюсь
Или просто сперва переименовать файл, как нужно коду ("C:\temp\biv\отчет.txt"), тогда диалога не будет.
Вот, нашёл про диалоги, выбор на любой вкус: http://forum.script-coding.info/view...pid=6509#p6509
P.S. Нашёл ещё в своём коде косячок (сразу видно, откуда диалог взялся ):
строку
If intResult = 0 Then Wscript.Quit
надо заменить на
If intResult = 0 Then Exit Sub

[KL (XL)]

Сообщение от Hugo121

...там просто суммы по кодам мало, там сперва надо эти коды частично изменить...

Действительно, проглядел

Сообщение от Hugo121

...И кстати Ваш код тоже у меня не идёт - сперва "Лист1", а затем .DataPivotField.PivotItems(1).Posit ion = 1...

Это чрезвычайно странно - у меня же в коде вроде нет нигде "Лист1", я использую имя уже существующего листа "Sheet1".

А второй сбой (.DataPivotField.PivotItems(1).Posi tion = 1) какую ошибку выдает? Скорее всего дело в версии Office 2000, а "мы с Microsoft" версии ранее 2003 не поддерживаем :P

Кстати, храните дистрибутив своего MSO2000 как зеницу ока - это уже раритет, его даже у Microsoft нет. Мне как-то понадобилось найти легальные дистрибутивы MSO 97 и 2000, я Microsoft по всему миру, включая Redmond, на уши поставил, так и не нашли. Пришлось качать нелегальщину. Она как, а скоро уже MSO2003 станет EOL

Сообщение от Hugo121

...Ну и ведь можно выбрать файл и привычным всем диалогом...

Да, лучше так наверное

[KL (XL)]

Вот это должно быть очень быстро (у меня в среднем 0,035 сек):

PHP код:

Sub CreateList2()
    Dim ws As Worksheet
    Dim wsRep As Worksheet
    Dim rng As Range
    Dim Arr
    Dim i As Long
    Dim Dict As Object
    Dim t As Double
    
    Set wsRep = ThisWorkbook.Worksheets("Sheet1")
    wsRep.Cells.Clear
    t = Timer
    Set Dict = CreateObject("Scripting.Dictionary")
    
    For Each ws In ThisWorkbook.Worksheets
        Set rng = ws.Range(ws.Cells(8, 1), ws.Cells(ws.Rows.Count, 1).End(xlUp))
        If ws.Name Like "Документ (*)" Then
            With Application
                Arr = Array(.Replace(.Replace(rng, 1, 3, "000"), 14, 4, "0000"), rng.Offset(, 12).Value)
                For i = 1 To UBound(Arr(0))
                    With Dict
                        If Arr(0)(i, 1) Like "####################" Then
                            If .Exists(Arr(0)(i, 1)) Then
                                .Item(Arr(0)(i, 1)) = .Item(Arr(0)(i, 1)) + Arr(1)(i, 1)
                            Else
                                .Add Arr(0)(i, 1), Arr(1)(i, 1)
                            End If
                        End If
                    End With
                Next i
            End With
        End If
    Next ws
    
    With wsRep
        With .Range("A1").Resize(Dict.Count)
            .NumberFormat = "@"
            .Value = Application.Transpose(Dict.keys)
        End With
        .Range("B1").Resize(Dict.Count) = Application.Transpose(Dict.items)
    End With
    
    MsgBox Timer - t
End Sub 


[Hugo121]

Да, с "Лист1" я ошибся, это у меня в книге "Лист1", поэтому Ваш ThisWorkbook.Worksheets("Sheet1") и не пошёл, пришлось менять на ThisWorkbook.Worksheets(13)
Ну а с 2000 - что стоит на работе, с тем и работаем... Это дома есть немного выбор
Последний вариант на Dictionary - Superбыстрый. Буду изучать.
Проверил на 2000 - результат один-в-один с моим, но быстрее, но мой ещё и сравнивает сразу
А чтоб с словарём сравнить - массив добавлять надо? Места то ведь больше нет для пометок, как у меня в массиве?
Но это будет всё равно быстрее - один раз создать массив, чем как у меня, 134 раза ReDim Preserve b(3, x)...

[KL (XL)]

Сообщение от Hugo121

А чтоб с словарём сравнить - массив добавлять надо? Места то ведь больше нет для пометок, как у меня в массиве?

На самом деле места полно, так как никто не запрещает присваивать проперти Item не текстовые значения, а массивы, где первый элемент - сумма по документам, а второй - значение из текстового файла

[biv]

Ребята, спасибо вам огромное!!!!!!!!
Посидела, поразбиралась - поняла, что к чему. Программу написать и подкорректировать - не смогу (это только ваши светлые и умные головы могут), но вставить эту программу в файл, вроде,получилось.
Скопировала все ваши решения и теперь 1-го числа буду пробовать. О результатах обязательно отпишусь.
ОГРОМНОЕ СПАСИБО ЗА ПОМОЩЬ ВСЕМ!!!!!!!!!!!!!!!!!!!!!!!!!