Excel 2003: почему данный макрос выдает Type mismatсh?

[bi-lya]

Чудовище под кроватью

Код: Выделить всё

If Not Range("A1:D20").Find(Empty, lookin:=xlValues) is Nothing Then

К сожалению, похоже, только теоретически. Не пошло, ни с Not, ни без него.
Ну а со SpecialCells - лишние телодвижения с фоматированием, как я понимаю

[bi-lya]

KL, уважаемый, так все-таки тогда насчет

Код: Выделить всё

Public Sub Nechto()
a = 1
With ActiveWorkbook.ActiveSheet
    Do While IsEmpty(.Cells(a, 2)) = False
        For b = 3 To 10
            If IsEmpty(.Cells(a, b)) = False Then
                Exit For
            End If
        If b = 10 Then Cells(a, 1).Value = .Cells(a, 2).Value
        Next b
    a = a + 1
    Loop
End With
End Sub

какие мысли? Какой вариант из предложенных мной и г-ном Чудовище под кроватью лучше? Рецензируйте, пожалуйста, с позиций верно понятой задачи. Может быть есть еще варианты?

[Чудовище под кроватью]

KL, уважаемый, так все-таки тогда насчет

Код: Выделить всё

Public Sub Nechto()
a = 1
With ActiveWorkbook.ActiveSheet
    Do While IsEmpty(.Cells(a, 2)) = False
        For b = 3 To 10
            If IsEmpty(.Cells(a, b)) = False Then
                Exit For
            End If
        If b = 10 Then Cells(a, 1).Value = .Cells(a, 2).Value
        Next b
    a = a + 1
    Loop
End With
End Sub

какие мысли? Какой вариант из предложенных мной и г-ном Чудовище под кроватью лучше? Рецензируйте, пожалуйста, с позиций верно понятой задачи! Или есть еще варианты?

Во-первых, от г-на слышу .
Во-вторых, я же тебе твой код доработал. - Просто сравни, который из кодов отработает быстрее (благо - там разница во времени видна и без OnTime).
В-третьих, КL, насколько я понял, предлагал SpecialCells для того, чтобы получить только непустые ячейки в столбце B. Т.е.

Код: Выделить всё

Range(Cells(7,2),Cells(ActiveWorksheet.UsedRange.Rows.Count,2)).SpecialCells(xlCellTypeBlanks)

В результате метод выдал бы все непустые ячейки столбца В. - Оптимальный вариант, если бы в столбце B заполненные ячейки чередовались с незаполненными. Но поскольку тут достаточно было пройти только до первой пустой ячейки в столбце B, мы просто получаем её номер строки из свойства End и циклом проходим от 7 до этого значения.

[KL]

Чудовище под кроватью

Код: Выделить всё

If Not Range("A1:D20").Find(Empty, lookin:=xlValues) is Nothing Then

К сожалению, похоже, только теоретически. Не пошло, ни с Not, ни без него.
Ну а со SpecialCells - лишние телодвижения с фоматированием, как я понимаю

Код: Выделить всё

If Not [A:A].Find("", [A7], xlValues) is Nothing Then

в сочетании с:
http://bbs.vbstreets.ru/viewtopic.php?p=6635155#6635155

но в рассматриваемом случае это не имеет смысла

[KL]

KL, уважаемый, так все-таки тогда насчет

Код: Выделить всё

Public Sub Nechto()
a = 1
With ActiveWorkbook.ActiveSheet
    Do While IsEmpty(.Cells(a, 2)) = False
        For b = 3 To 10
            If IsEmpty(.Cells(a, b)) = False Then
                Exit For
            End If
        If b = 10 Then Cells(a, 1).Value = .Cells(a, 2).Value
        Next b
    a = a + 1
    Loop
End With
End Sub

какие мысли? Какой вариант из предложенных мной и г-ном Чудовище под кроватью лучше? Рецензируйте, пожалуйста, с позиций верно понятой задачи! Или есть еще варианты?

Мысли такие:

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

2) если добавить условие с форматом (напр. Bold), то и это решение потеряет свою актуальность.

3) я предпочитаю решения через формулы, но если бы задача решалась только через цикл, то я бы плясал от след. кода:

Код: Выделить всё

Public Sub Nechto()
    Dim c As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        For Each c In .Range(.[B7], .[B7].End(xlDown))
            If Application.CountA(c.Offset(, 1).Resize(, 7)) = 0 Then _
                c.Offset(, -1) = c
        Next c
    End With
    Application.ScreenUpdating = True
End Sub

[bi-lya]

KL
Большое спасибо, что ответили. Все-таки я проведу лабораторную работу на скорость выполнения
Чудовище под кроватью
Извините, т-щ (такое сокращение вроде ничего?), я ваше заявление "... я же тебе твой код доработал..." ну никак не могу принять , тем более что я свою точку зрения С САМОГО НАЧАЛА ( в отличие от) отстаивал .
После проведения лабораторной отзвоню!

[bi-lya]

Как обещал - результаты тестов.
Оборудование: проц. Celeron 434
тест №1 - работа с диапазоном C3:I65536 - 524288 ячеек
тест №2 - работа с диапазоном С3:IR65536 - 16384000 ячеек
Код KL

Код: Выделить всё

Public Sub Nechto()
    Dim c As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        For Each c In .Range(.[B7], .[B7].End(xlDown))
            If Application.CountA(c.Offset(, 1).Resize(, 250)) = 0 Then _
                c.Offset(, -1) = c
        Next c
    End With
    Application.ScreenUpdating = True
End Sub

Код Чудовище под кроватью

Код: Выделить всё

Sub smpl()
    Dim Cell As Range
    Application.ScreenUpdating = False
    For Each Cell In Range(Cells(1, 1), Cells(Cells(1, 2).End(xlDown).Row, 1))
        With Cell
            If Not (IsEmpty(.Offset(0, 1))) And WorksheetFunction.CountA _
               (Range(.Offset(0, 2), .Offset(0, 250))) = 0 Then Cell = .Offset(0, 1)
        End With
    Next Cell
    Application.ScreenUpdating = True
End Sub

И код bi-lya

Код: Выделить всё

Public Sub Nechto1()
Application.ScreenUpdating = False
a = 1
b = 3
With ActiveWorkbook.ActiveSheet
    Do While IsEmpty(.Cells(a, 2).Value) = False
        Do While IsEmpty(.Cells(a, b).Value) = True
             b = b + 1
            If b = 255 Then
                .Cells(a, 1).Value = .Cells(a, 2).Value
                Exit Do
            End If
        Loop
        b = 3
        a = a + 1
        If a = 65537 Then Exit Do
    Loop
End With
Application.ScreenUpdating = True
End Sub

Ну и сами результаты:

------------------KL---------------ЧПК------------bi
тест №1-------0.41.45---------0. 41.52------1.10.77
тест №2-------0.41.61---------0.45.24------22.12.75

Выводы для себя: даже для такого - я бы не сказал маленького - диапазона в 524288 ячеек на процессоре Celeron 434 разницу меньше чем в 30 сек я бы не назвал "чудовищным извращением". Конечно, результы теста №2 намнОго "красивее", поэтому я то же самое тестирование провел дома, на своем Пне Ко2Дуэ 6400 - 2130 МГц по ядру

-------------------KL--------------ЧПК------------bi
тест №1-------0.02.70---------0.02.87-------0.04.50
тест №2-------0.02.80---------0.02.87-------1.15.35

А здесь разница по времени для более 16 млн ячеек 27 сек - говорит само за себя .
Но методы и функции знать нужно!

[Чудовище под кроватью]

Как обещал - результаты тестов.

Это все по сути один и тот же алгоритм, просто у KL он написан правильнее. Ты сравни по быстродействию код KL и код заполнения формулами.
Сравнил макрос заполнения формулами на своем компе (проц 1,7) макрос заполнения формулами с циклом, который написал КL (поскольку в плане кода он лучший из трех) при 65535 строках.
Итог явно не в пользу цикла:
0,58 сек. занимает заполнение при первом проходе и до 0,8 при повторных - незначительное увеличение времени работы из-за пересчета формул.
Цикл занял 6,59 сек.

В общем, цикл подходит только для небольших объемов.

[KL]

(!) Мой ответ был написан раньше, чем появился пост "Чудовища под кроватью", но по неведомым мне причинам я смог загрузить его только сейчас

Привет bi-lyaб

а теперь проведи оба теста с кодом использующим формулу и убедись в том, что все 3 приведенных ранее кода - "чудовищное извращение" ))

Код: Выделить всё

Public Sub Nechto()
    Dim c As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        With .Range(.[B7], .[B7].End(xlDown)).Offset(, -1)
            .Value = "=IF(AND(RC[1]<>"""",COUNTA(RC[2]:RC[251])=0),RC[1],"""")"
            .Value = .Value
        End With
    End With
    Application.ScreenUpdating = True
End Sub

И еще о том, является ли код длящийся 1.15 мин оптимальным в Excel:

http://www.decisionmodels.com/optspeed.htm

[bi-lya]

Чудовище под кроватью, да я в общем-то ничего не имею против вашего кода, я сравнивал (скажу, наверно, охренительно круто) код "чистого" VB и код с использованием экселевского метода.
KL А я что-то повесился и пока не разберу в чем проблема...This codе у вас работает? И, если не затруднит, - каким образом идем вниз по строкам? (пользую 11 офис, SP1)
Я смотрю, наш собеседник предлагал нечто подобное (см. 5 ответ) "...=ЕСЛИ(И(НЕ(ЕПУСТО(B1));СЧЁТЗ(C1:I1)=0);B1;"")..."?

[KL]

Я так понимаю, что отдуваться мне

Значит, вот мое видение ситуации

1. Промеры скорости для 65.529 строк на
HW: Intel Core Duo T2600 2.16 MHz, RAM 3GB (4GB) 667MHz
OS: Windows Vista Ultimate Retail (Aero mode) 32-bit
MSO: 2003

2. Результаты (сек.)

Код: Выделить всё

      7 columns      254 columns
FRM_KL      0.328125      не дождался
FRM_Beast   0.375000      не дождался
VBA_KL      2.250000      2.265625
VBA_Beast   2.296800      2.296875
VBA_bi_lya   6.562625      64.32813

3. Причина проблем с кодом использ. формулы в 254 столбцах: я думаю - превышение лимита в 65536 "dependencies", в результате чего все формулы становятся летучими и пересчитываются все разом если пересчитывается хоть одна и независимо от того стоит ли ручной пересчет (см: http://www.decisionmodels.com/calcsecretsd.htm )

4. Вывод: формулы лучше, но не всегда

5. Отмазки: в поставленной задаче речь шла о 7 столбцах

6. Собственно код:

Код: Выделить всё

Sub VBA_KL()
    Dim c As Range
    t = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    With ActiveSheet
        For Each c In .Range(.[B7], .[B7].End(xlDown))
            If Application.CountA(c.Offset(, 1).Resize(, 254)) = 0 Then _
                c.Offset(, -1) = c
        Next c
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    MsgBox Timer - t
End Sub

Sub VBA_bi_lya()
    t = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    a = 7
    b = 3
    With ActiveWorkbook.ActiveSheet
        Do While IsEmpty(.Cells(a, 2).Value) = False
            Do While IsEmpty(.Cells(a, b).Value) = True
                b = b + 1
                If b = 256 Then
                    .Cells(a, 1).Value = .Cells(a, 2).Value
                    Exit Do
                End If
            Loop
            b = 3
            a = a + 1
            If a = 65537 Then Exit Do
        Loop
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    MsgBox Timer - t
End Sub

Sub VBA_Beast()
    Dim Cell As Range
    t = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    For Each Cell In Range(Cells(7, 1), Cells(Cells(7, 2).End(xlDown).Row, 1))
        With Cell
            If Not (IsEmpty(.Offset(0, 1))) And WorksheetFunction.CountA _
               (Range(.Offset(0, 2), .Offset(0, 255))) = 0 Then Cell = .Offset(0, 1)
        End With
    Next Cell
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    MsgBox Timer - t
End Sub

Sub FRM_KL()
    Dim c As Range
    t = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    With ActiveSheet
        With .Range(.[B7], .[B7].End(xlDown)).Offset(, -1)
            .Value = "=IF(AND(RC[1]<>"""",COUNTA(RC[2]:RC[255])=0),RC[1],"""")"
            .Value = .Value
        End With
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    MsgBox Timer - t
End Sub

Sub FRM_Beast()
    t = Timer
    Application.ScreenUpdating = False
    'Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Cells(7, 1).FormulaR1C1 = "=IF(AND(NOT(ISBLANK(RC[1])),COUNTA(RC[2]:RC[255])=0),RC[1],"""")"
    With Range(Cells(7, 1), Cells(Cells(7, 2).End(xlDown).Row, 1))
        .FillDown
        '.Calculate
        .Value = .Value
    End With
    'Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    MsgBox Timer - t
End Sub

[KL]

...И, если не затруднит, - каким образом идем вниз по строкам? (пользую 11 офис, SP1)

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

...Я смотрю, наш собеседник предлагал нечто подобное (см. 5 ответ) "...=ЕСЛИ(И(НЕ(ЕПУСТО(B1));СЧЁТЗ(C1:I1)=0);B1;"")..."?

Да, идея и формула "нашего собеседника", только я заменил FillDown на более экономичное прямое присвоение формулы - так она бежит слегка побыстрее.