none
Подскажите как исправить не большой макрос в Excel RRS feed

  • Вопрос

  • Есть макрос, написан мной

    Sub createReport()
        Dim first As Integer
        Dim second As Integer
        With Worksheets("Бородулиха")
            If WorksheetFunction.CountA(.Cells) > 0 Then
                 'Search for any entry, by searching backwards by Rows
                first = .Cells.Find(What:="*", After:=.Range("A7"), SearchOrder:=xlByRows, _
                SearchDirection:=xlNext).Row
            End If
        End With
        
         
        With Worksheets("Глубокое")
            If WorksheetFunction.CountA(.Cells) > 0 Then
                 'Search for any entry, by searching backwards by Rows
                second = .Cells.Find(What:="*", After:=.Range("A7"), SearchOrder:=xlByRows, _
                SearchDirection:=xlNext).Row
            End If
        End With
        Call filler(first, second)
    End Sub
    Sub filler(first, second)
    
        Worksheets("Печать").Cells(first + 1, 1) = Worksheets("Бородулиха").Cells(7, 1)
        For y = 1 To first
            For i = 1 To 14
                Worksheets("Печать").Cells(first + y + 1, i) = Worksheets("Бородулиха").Cells(7 + y, i)
            Next i
        Next y
        second = second + first
        Worksheets("Печать").Cells(second + 1, 1) = Worksheets("Глубокое").Cells(7, 1)
        For y = 1 To second
            For i = 1 To 14
                Worksheets("Печать").Cells(second + y + 1, i) = Worksheets("Глубокое").Cells(7 + y, i)
            Next i
        Next y
    End Sub
                
    
    Предназначение: из нескольких листов нужно скопировать не пустые строки в другой лист "Печать", но так, что бы данные из каждых листов были последовательными и не затирали данные друг друга, сейчас этот код работает нормально, но добавляет 8 строк, пустые или нет все равно, и это проблема. не знаю VB и макросы, посмотрел пару примеров и написал, но работает не правильно. Как исправить подскажите, или как надо написать.


    if (Thread.Was == HelpFul) Mark.As(HelpFul); else if (Thread.Was == Answered) Mark.As(Answered); else Provide(More.Details);

    7 июня 2014 г. 10:07

Ответы

  • Вы забыли упомянуть, что Ваш макрос, не маленький :))

    Выполнение остатков макроса взятого из приведённого в статье и Вашим:

    Sub БородулихаГлубокое()
       
       'очистка Листа "Печать" от результата действия макроса
    ThisWorkbook.Sheets("Печать").Cells.Clear
    
        Dim first As Integer
        Dim second As Integer
        With Worksheets("Бородулиха")
            If WorksheetFunction.CountA(.Cells) > 0 Then
                 'Search for any entry, by searching backwards by Rows
                first = Worksheets("Бородулиха").Cells.Find(What:="*", _
                     After:=Worksheets("Бородулиха").Cells.Range("A1"), _
                     SearchDirection:=xlPrevious, _
                     LookIn:=xlFormulas, _
                     SearchOrder:=xlByRows).Row
        Set SourceRange = Worksheets("Бородулиха").Range("A10:C10" & first)
            End If
        End With
        first = Worksheets("Бородулиха").Cells(first + y, 1)
        For y = 1 To first
             'установка количества столбцов переносимых данных в примере со столбцов с А по С
            For i = 1 To 3
                Worksheets("Печать").Cells(y, i) = Worksheets("Бородулиха").Cells(y, i)
            Next i
        Next y
        
        'увеличивая число 1, увеличиваем отступ от предыдущего блока "Бородулиха"
        second = first
                Worksheets("Печать").Cells(second + 2, 1) = Worksheets("Глубокое").Cells(1, 1)
        For y = 1 To second
             'установка количества столбцов переносимых данных в примере со столбцов с А по С
            For i = 1 To 3
                Worksheets("Печать").Cells(second + y, i) = Worksheets("Глубокое").Cells(y, i)
            Next i
        Next y
    
    End Sub

    Приведёт к результату:

    Файл-пример с этим макросом.


    Да, я Жук, три пары лапок и фасеточные глаза :))







    12 июня 2014 г. 21:53
    Модератор

Все ответы

  • Было бы ещё лучше, если бы Вы добавили ссылки на примеры, по которым создавали свой макрос.

    P.S. Информация к размышлению:

    Два Листа, "Глубокое" и "Бородулиха", заполнены по 20 строк (A1:D28), представленный Вами макрос на Листе "Печать" выводит результат:


    Да, я Жук, три пары лапок и фасеточные глаза :))



    8 июня 2014 г. 22:54
    Модератор
  • Необходимо внимательно разбираться с первым блоком второй части макроса.

    Информация к размышлению:

    При изменении макроса, во второй части второго блока, на:

        second = first + i
        Worksheets("Печать").Cells(second + 1, 1) = Worksheets("Глубокое").Cells(1, 1)
        For y = 1 To second
            For i = 1 To 14
                Worksheets("Печать").Cells(second + y, i) = Worksheets("Глубокое").Cells(y, i)
            Next i
        Next y

    на Лист "Печать" выводится результат для "Глубокое":

    как видно на представленном выше скриншоте, блок макроса "Глубокое" отрабатывает правильно, перенося все строки с A1 по D20.


    Да, я Жук, три пары лапок и фасеточные глаза :))


    Модератор
  • файл тут http://1drv.ms/1pt5Rd9

    в том коде не много не правильно

     first = .Cells.Find(What:="*", After:=.Range("A7"), SearchOrder:=xlByRows, _
                SearchDirection:=xlNext).Row

    и это

      second = .Cells.Find(What:="*", After:=.Range("A7"), SearchOrder:=xlByRows, _
                SearchDirection:=xlNext).Row

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

    P.S. vb ужасен, но компилятор резвый, была бы процедурная имплементация C# для excel было бы замечательно


    if (Thread.Was == HelpFul) Mark.As(HelpFul); else if (Thread.Was == Answered) Mark.As(Answered); else Provide(More.Details);

  • Если Вы про параметр .Range("A7"), то это указатель начальной строки из остатков кода, который Вы взяли за основу.

    В любом случае, нужно смотреть весь код, так как например код поиска снизу вверх первой пустой строки, при условии начала заполнения со строки А1 и известного последнего столбца "К", "Копирование диапазона, который расширяется до последней строки" будет таким:

        Dim LastRow As Long
        LastRow = Worksheets(1).Cells.Find(What:="*", _
                     After:=Worksheets(1).Cells.Range("A1"), _
                     SearchDirection:=xlPrevious, _
                     LookIn:=xlFormulas, _
                     SearchOrder:=xlByRows).Row
        Set SourceRange = Worksheets(1).Range("A8:K" & LastRow)

    Для экспериментов над макросом, лучше вставлять второй строкой код:

        'очистка предыдущего результата действия макроса
    ThisWorkbook.Sheets("ЛистВыводаРезультатаМакроса").Cells.Clear


    Да, я Жук, три пары лапок и фасеточные глаза :))



    12 июня 2014 г. 18:13
    Модератор
  • Вы забыли упомянуть, что Ваш макрос, не маленький :))

    Выполнение остатков макроса взятого из приведённого в статье и Вашим:

    Sub БородулихаГлубокое()
       
       'очистка Листа "Печать" от результата действия макроса
    ThisWorkbook.Sheets("Печать").Cells.Clear
    
        Dim first As Integer
        Dim second As Integer
        With Worksheets("Бородулиха")
            If WorksheetFunction.CountA(.Cells) > 0 Then
                 'Search for any entry, by searching backwards by Rows
                first = Worksheets("Бородулиха").Cells.Find(What:="*", _
                     After:=Worksheets("Бородулиха").Cells.Range("A1"), _
                     SearchDirection:=xlPrevious, _
                     LookIn:=xlFormulas, _
                     SearchOrder:=xlByRows).Row
        Set SourceRange = Worksheets("Бородулиха").Range("A10:C10" & first)
            End If
        End With
        first = Worksheets("Бородулиха").Cells(first + y, 1)
        For y = 1 To first
             'установка количества столбцов переносимых данных в примере со столбцов с А по С
            For i = 1 To 3
                Worksheets("Печать").Cells(y, i) = Worksheets("Бородулиха").Cells(y, i)
            Next i
        Next y
        
        'увеличивая число 1, увеличиваем отступ от предыдущего блока "Бородулиха"
        second = first
                Worksheets("Печать").Cells(second + 2, 1) = Worksheets("Глубокое").Cells(1, 1)
        For y = 1 To second
             'установка количества столбцов переносимых данных в примере со столбцов с А по С
            For i = 1 To 3
                Worksheets("Печать").Cells(second + y, i) = Worksheets("Глубокое").Cells(y, i)
            Next i
        Next y
    
    End Sub

    Приведёт к результату:

    Файл-пример с этим макросом.


    Да, я Жук, три пары лапок и фасеточные глаза :))







    12 июня 2014 г. 21:53
    Модератор