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

[nilem]

Вот так попробуйте:

Sub ertert3()
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 = Val(x(i, 1))
            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 = Val(x(i, 1))
                    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 + 10000, 1 To 1)
    For Each w In .keys
        If IsNumeric(w) 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]

класс! пасиб большое!!!

[manowar_gub]

а можно небольшое уточнение? попробовал добавить 3 лист для сравнения

PHP код:

    For Each w In [{"KredHistory", "Реестр", [B]"Реестр2"[/B]}]
        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, [B].Range("AJ2", .Cells(Rows.Count, "AJ").End(xlUp)).Value[/B]) 


однако вылезает ошибка "неверное число аргументов" - наверное всё сложнее для добавки 3 листа?)

[manowar_gub]

а можно небольшое уточнение? попробовал добавить 3 лист для сравнения

PHP код:

    For Each w In [{"KredHistory", "Реестр", "Реестр2"}]
        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, .Range("AJ2", .Cells(Rows.Count, "AJ").End(xlUp)).Value) 


однако вылезает ошибка "неверное число аргументов" - наверное всё сложнее для добавки 3 листа?)

[nilem]

Можно как-то так, например:

Dim ArrWsh, x, i&
ArrWsh = Array("KredHistory", "M", "Реестр", "AO", "Реестр2", "X")
For i = LBound(ArrWsh) To UBound(ArrWsh) Step 2
    With Sheets(ArrWsh(i))
        x = .Range(ArrWsh(i + 1) & 8, .Cells(Rows.Count, ArrWsh(i + 1)).End(xlUp)).Value
    End With
Next

[manowar_gub]

пасиб!

теперь новинка))) сортировка по убыванию диапазона, где сначала находит низ (там ячейка начинается с букв Итог) а потом находит верх (там ячейка пустая). но компилятор ругается на некорректное условия сортировки... подскажите, что не так?

PHP код:

For x = 7 To 45
If Mid(Sheets("Сводный").Cells(x, 2).Value, 1, 4) = "Итог" Then
    niz = Sheets("Сводный").Cells(x, 2).Row - 1
        z = Sheets("Сводный").Cells(x, 2).Row - 1
        While Sheets("Сводный").Cells(z, 2).Value = Empty
        If Sheets("Сводный").Cells(z, 2).Value = Empty Then verh = Sheets("Сводный").Cells(z, 2).Row + 1
        z = z - 1
        Wend
m = Sheets("Сводный").Range("B" & niz, "K" & verh).Sort(Key1:=Range("B" & verh), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal)

End If


Next x 


[manowar_gub]

разобрался сам)

p.s. мож как-то проще можно?... а то пишу основываясь за записях макросов и базовых знаний программирования)

PHP код:

For x = 7 To 45
If Mid(Sheets("Сводный").Cells(x, 2).Value, 1, 4) = "Итог" Then
    niz = Sheets("Сводный").Cells(x, 2).Row - 1
        z = Sheets("Сводный").Cells(x, 2).Row - 1
        While Sheets("Сводный").Cells(z, 2).Value <> Empty
        verh = Sheets("Сводный").Cells(z, 2).Row
        z = z - 1
        Wend
o = Worksheets("Сводный").Range("B" & niz, "K" & verh).Sort(Key1:=Range("B" & verh), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal)


End If


Next x 


[nilem]

пробуйте

On Error Resume Next 'если вдруг "Итог..." не найдется
With Sheets("Сводный").Columns(2).Find("Итог*")
    With Range(.Offset(-1), .End(xlUp)).Resize(, 10)
        .Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlGuess
    End With
End With
On error Goto 0