Открыть книгу Excel в Excel

[manowar_gub]

нифига не работает)

PHP код:

Dim a(), b(), bb(), c(), iLastrow As Long, i As Long, t&
    Application.ScreenUpdating = False

    With Sheets("Реестр")
        'iLastrow = .Cells(Rows.Count, 41).End(xlUp).Row
        a = Range(.[AO2], .Range("AO12548")).Value
        c = Range(.[AP2], .Range("AP12548")).Value
    End With

    With Sheets("Сводный")
        'iLastrow = .Cells(Rows.Count, 1).End(xlUp).Row
        b = Range(.[A7], .Range("A375")).Value
        bb = Range(.[L7], .Range("L375")).Value
    End With


    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(b)
            .Item(b(i, 1)) = i
        Next

        For i = 1 To UBound(a)
            If .exists(a(i, 1)) Then
                t = .Item(a(i, 1))
                Select Case bb(t, 1)
                Case 2011: c(i, 1) = bb(t, 3)
                Case 2012: c(i, 1) = bb(t, 3)
                End Select
            End If
        Next
    End With

    Sheets("Сводный").[M1].Resize(UBound(c), 2) = c

End Sub 


так и не понял что даёт case и каким образом происходит сравнение в п.4... также по определению диапазонов - там есть пустые ячейки - это никак не влияет?

p.s. в a и b задал диапазоны, c и bb = дубляжи диапазонов?

[Hugo121]

Без файла конечно только гадаю, но что точно наверняка не работает, это вот :

Select Case bb(t, 1)
                Case 2011: c(i, 1) = bb(t, 3)
                Case 2012: c(i, 1) = bb(t, 3)
                End Select

Здесь выше ( t = .Item(a(i, 1))) в переменную извлекаю индекс найденной пары, по индексу из массива bb берём значение (год в данном случае). далее по условию той задачи нужно результат положить в нужный столбец в зависимости от года.
Весь этот блок Вам не нужен. А может нужен, но другой - откуда мне знать?

По пустым - лучше пустые при занесении в словарь откидывать - иначе потом к каждой пустой будут тянуться данные из запомненной в словаре последней пустой - а там ведь в других столбцах/массивах может быть что-то записано. А может так и нужно, как знать...

А сравнение происходит так - просмотрели диапазон, запомнили все присутствующие значения (и их позиции заодно), затем просматриваем второй диапазон и сразу раскладываем данные по парам.

c и bb - не дубляжи, а такие же по размеру массивы из других столбцов. В принципе, можно без них обойтись, сделав изначальные массивы шире, и работать только с ними, но зачем тягать столько лишних данных?

[manowar_gub]

согласен, без файла конструктива будет мало...

на листе сводный список фамилий с группировкой по шифрами абонентских отделов (8801, 5504 и т.п.). разделяют группировки отделов 2 пустых строки.

что пытаюсь сделать - из листа "кредхистори" столбца M и листа "реестр" столбца AO сравнить значения с листом "сводный" столбец А, если встретились кого там нет - добавить строку внизу учитывая шифр абонентских отделов...

сразу пример - 8801ПавловскийМС отсутствует в столбце А листа "сводный", поэтому его надо внести туда по адресу А14, сохранив 2 строки разницы между отделов. весь перечень отделов есть в столбце сводный, разница отделов - в написании 4 первых цифр.

[Hugo121]

Узкое место - "внести туда по адресу А14, сохранив 2 строки".
Сделать можно, но так много кода нужно написать...
Может быть можно заранее под каждым отделом заготовить две строки вида 8801яяяяяяяяяяяяяяяяяяяяя
и потом просто добавлять новые данные ниже без разбора, затем отсортировать?
Только нужно ещё предусмотреть, чтоб отделы правильно сортировались, а не так, как сейчас.

Тогда алгоритм может быть такой - сводный в словарь, создаём массив размером с сумму размеров "кредхистори" и "реестр", каждый из них сверяем с словарём, если нет в словаре - копируем в созданный массив, его в конце выгружаем под "сводный", сортируем.
Если без сортировки - тогда даже не знаю, как реализовать... Кучу словарей и массивов что-ли делать....

Ну или можно использовать

 CreateObject("System.Collections.ArrayList")

Туда можно загрузить весь сводный, затем при отсутствии добавляем новые (аналогично как со словарём, но конечно синтаксис чуть другой), в конце отсортировать (есть встроенный метод), потом начинаем по одному выгружать на лист - как сменился отдел, добавляем две строки и выгружаем дальше.

Хотя опять же чтоб соблюдать порядок не по алфавиту, а как нужно - нужно перед названием отдела добавить индекс для сортировки по алфавиту

[nilem]

вариант (активный лист "Сводный")

Sub ertert()
Dim x(), i&, j&, s$, t(), w
With Range("A7", Cells(Rows.Count, "A").End(xlUp))
    x = .Value: .ClearContents
End With

With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        If Len(x(i, 1)) Then
            .Item(x(i, 1)) = 1: s = Left(x(i, 1), 4)
            If Not .exists(s) Then
                .Item(s) = Array(x(i, 1))
            Else
                t = .Item(s)
                ReDim Preserve t(UBound(t) + 1)
                t(UBound(t)) = x(i, 1): .Item(s) = t
            End If
        End If
    Next i

    For Each w In [{"KredHistory", "Реестр"}]
        With Sheets(w)
            x = IIf(w = "KredHistory", .Range("M8", .Cells(Rows.Count, "M").End(xlUp)).Value, _
                    .Range("AO2", .Cells(Rows.Count, "AO").End(xlUp)).Value)
        End With
        For i = 1 To UBound(x)
            If Len(x(i, 1)) Then
                If Not .exists(x(i, 1)) Then
                    .Item(x(i, 1)) = 1: s = Left(x(i, 1), 4)
                    If Not .exists(s) Then
                        .Item(s) = Array(x(i, 1))
                    Else
                        t = .Item(s)
                        ReDim Preserve t(UBound(t) + 1)
                        t(UBound(t)) = x(i, 1): .Item(s) = t
                    End If
                End If
            End If
        Next i
    Next w

    ReDim x(1 To .Count + 1000, 1 To 1)
    For Each w In .keys
        If Len(w) = 4 Then
            t = .Item(w)
            For i = 0 To UBound(t)
                j = j + 1: x(j, 1) = t(i)
            Next i
            j = j + 2
        End If
    Next w
End With
Range("A7").Resize(j).Value = x()
End Sub

[manowar_gub]

а может быть сразу соединить 2 range в 1, отсортировать и выгрузить в "сводный"? т.е. каждый раз будет заново строиться!

[nilem]

С массивами, похоже, переборщил

Sub ertert2()
Dim x(), i&, j&, s$, w, t
With Range("A7", Cells(Rows.Count, "A").End(xlUp))
    x = .Value: .ClearContents
End With
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        If Len(x(i, 1)) Then
            .Item(x(i, 1)) = 1: s = Left(x(i, 1), 4)
            If Not .exists(s) Then .Item(s) = x(i, 1) Else .Item(s) = .Item(s) & "|" & x(i, 1)
        End If
    Next i
    For Each w In [{"KredHistory", "Реестр"}]
        With Sheets(w)
            x = IIf(w = "KredHistory", .Range("M8", .Cells(Rows.Count, "M").End(xlUp)).Value, _
                    .Range("AO2", .Cells(Rows.Count, "AO").End(xlUp)).Value)
        End With
        For i = 1 To UBound(x)
            If Len(x(i, 1)) Then
                If Not .exists(x(i, 1)) Then
                    .Item(x(i, 1)) = 1: s = Left(x(i, 1), 4)
                    If Not .exists(s) Then .Item(s) = x(i, 1) Else .Item(s) = .Item(s) & "|" & x(i, 1)
                End If
            End If
        Next i
    Next w
    ReDim x(1 To .Count + 1000, 1 To 1)
    For Each w In .keys
        If Len(w) = 4 Then
            t = Split(.Item(w), "|")
            For i = 0 To UBound(t)
                j = j + 1: x(j, 1) = t(i)
            Next i
            j = j + 2
        End If
    Next w
End With
Range("A7").Resize(j).Value = x()
End Sub

[manowar_gub]

2 nilem

супер! работает! пасиб большое!

p.s. при формировании последнего отдела почему-то шпарит через 2 строчки некоторые фамилии... можно конечно сделать макрос чтобы проверял значения между пустотами и если отделы совпадают то удалял их, но может быть можно чтобы сразу были без пустот...?

а так офигенно! просто адский труд!

[nilem]

Покажите примерчик в файле, где появляются 2 ненужные строчки

[manowar_gub]

блин мне кажется я понял в чём... косяк в том что 1 отдел состоит из 3 цифр...