0

Собрал макрос для работы с файлом, суть его в работе с листами файла и копированием данных с листов на основной лист.

При запуске через окно ВБА или по пути разраб-макросы-выполнить все отлично работает. Назначаю на кнопку - не работает. Чертовщина какая-то для меня.

   Public Sub HHHH()

    Dim LastRow, LastRow2, Lastcolumn, LastRow3, Lastcolumn2, LastRow4, Lastcolumn3 As Long
    Dim a As Long
    Dim Rw, Rw2, Rw3, Rw4, Rw5 As Long

    ThisWorkbook.Sheets("Неделя").Range("a17:y300") = ""
    a = ThisWorkbook.Sheets("Неделя").Cells(2, 2)
    LastRow = ThisWorkbook.Sheets("Банк").Cells(Rows.Count, 1).End(xlUp).Row
    LastRow2 = ThisWorkbook.Sheets("Поступления").Cells(Rows.Count, 1).End(xlUp).Row
    Lastcolumn = ThisWorkbook.Sheets("Поступления").Cells(1, Columns.Count).End(xlToLeft).Column
    LastRow3 = ThisWorkbook.Sheets("Затраты").Cells(Rows.Count, 1).End(xlUp).Row
    Lastcolumn2 = ThisWorkbook.Sheets("Затраты").Cells(1, Columns.Count).End(xlToLeft).Column
    LastRow4 = ThisWorkbook.Sheets("Счета").Cells(Rows.Count, 1).End(xlUp).Row
    Lastcolumn3 = ThisWorkbook.Sheets("Счета").Cells(1, Columns.Count).End(xlToLeft).Column
          Application.ScreenUpdating = False
           ThisWorkbook.Sheets("Банк").Activate
         With ThisWorkbook.Sheets("Неделя")
            Rw = ThisWorkbook.Sheets("Неделя").Cells(Rows.Count, 1).End(xlUp).Row + 1
            For i = 1 To LastRow
                If Cells(i, 13) = a And Cells(i, 2) > 0 Then
                   ThisWorkbook.Sheets("Банк").Range(ThisWorkbook.Sheets("Банк").Cells(i, 1), ThisWorkbook.Sheets("Банк").Cells(i, 2)).Copy
                   ThisWorkbook.Sheets("Неделя").Cells(Rw, 1).PasteSpecial xlPasteValues
                   ThisWorkbook.Sheets("Банк").Range(ThisWorkbook.Sheets("Банк").Cells(i, 4), ThisWorkbook.Sheets("Банк").Cells(i, 5)).Copy
                   ThisWorkbook.Sheets("Неделя").Cells(Rw, 3).PasteSpecial xlPasteValues
                   ThisWorkbook.Sheets("Банк").Cells(i, 19).Copy
                   ThisWorkbook.Sheets("Неделя").Cells(Rw, 5).PasteSpecial xlPasteValues
                    Rw = Rw + 1
                End If
            Next
          End With
          With ThisWorkbook.Sheets("Неделя")
            Rw2 = ThisWorkbook.Sheets("Неделя").Cells(Rows.Count, 11).End(xlUp).Row + 1
            For Z = 1 To LastRow
                If Cells(Z, 13) = a And Cells(Z, 3) > 0 Then
                   ThisWorkbook.Sheets("Банк").Cells(Z, 1).Copy
                   ThisWorkbook.Sheets("Неделя").Cells(Rw2, 11).PasteSpecial xlPasteValues
                   ThisWorkbook.Sheets("Банк").Range(ThisWorkbook.Sheets("Банк").Cells(Z, 3), ThisWorkbook.Sheets("Банк").Cells(Z, 5)).Copy
                   ThisWorkbook.Sheets("Неделя").Cells(Rw2, 12).PasteSpecial xlPasteValues
                   ThisWorkbook.Sheets("Банк").Cells(Z, 22).Copy
                   ThisWorkbook.Sheets("Неделя").Cells(Rw2, 15).PasteSpecial xlPasteValues
                    Rw2 = Rw2 + 1
                End If
            Next
           End With
           With ThisWorkbook.Sheets("Неделя")
             ThisWorkbook.Sheets("Поступления").Activate
            Rw3 = ThisWorkbook.Sheets("Неделя").Cells(Rows.Count, 6).End(xlUp).Row + 1
            For in1 = 1 To Lastcolumn
                For in2 = 2 To LastRow2
                If Cells(1, in1) = a And Cells(in2, in1) > 0 Then
                   ThisWorkbook.Sheets("Поступления").Cells(in2, in1).Copy
                   ThisWorkbook.Sheets("Неделя").Cells(Rw3, 8).PasteSpecial xlPasteValues
                   ThisWorkbook.Sheets("Поступления").Range(ThisWorkbook.Sheets("Поступления").Cells(in2, 1), ThisWorkbook.Sheets("Поступления").Cells(in2, 2)).Copy
                   ThisWorkbook.Sheets("Неделя").Cells(Rw3, 6).PasteSpecial xlPasteValues
                    Rw3 = Rw3 + 1
                End If
                Next
            Next
          End With
          With ThisWorkbook.Sheets("Неделя")
                   ThisWorkbook.Sheets("Затраты").Activate
            Rw4 = ThisWorkbook.Sheets("Неделя").Cells(Rows.Count, 18).End(xlUp).Row + 1
            For out1 = 1 To Lastcolumn2
                For out2 = 2 To LastRow3
                If Cells(1, out1) = a And Cells(out2, out1) > 0 Then
                   ThisWorkbook.Sheets("Затраты").Cells(out2, out1).Copy
                   ThisWorkbook.Sheets("Неделя").Cells(Rw4, 21).PasteSpecial xlPasteValues
                   ThisWorkbook.Sheets("Затраты").Cells(out2, 1).Copy
                   ThisWorkbook.Sheets("Неделя").Cells(Rw4, 18).PasteSpecial xlPasteValues
                   ThisWorkbook.Sheets("Затраты").Cells(out2, 3).Copy
                   ThisWorkbook.Sheets("Неделя").Cells(Rw4, 20).PasteSpecial xlPasteValues
                    Rw4 = Rw4 + 1
                End If
                Next
            Next
             End With
          With ThisWorkbook.Sheets("Неделя")
                   ThisWorkbook.Sheets("Счета").Activate
            Rw5 = ThisWorkbook.Sheets("Неделя").Cells(Rows.Count, 24).End(xlUp).Row + 1
            For bill1 = 1 To Lastcolumn2
                For bill2 = 2 To LastRow3
                If Cells(1, bill1) = a And Cells(bill2, bill1) > 0 Then
                   ThisWorkbook.Sheets("Счета").Cells(bill2, bill1).Copy
                   ThisWorkbook.Sheets("Неделя").Cells(Rw5, 25).PasteSpecial xlPasteValues
                   ThisWorkbook.Sheets("Счета").Cells(bill2, 2).Copy
                   ThisWorkbook.Sheets("Неделя").Cells(Rw5, 24).PasteSpecial xlPasteValues

                    Rw5 = Rw5 + 1
                End If
                Next
            Next
        End With

     ThisWorkbook.Sheets("Неделя").Activate
     Application.ScreenUpdating = True
    End Sub    

Помогите плиз решить головоломку.

P.s. нашел странность - после выполнения макроса, остаются данные которые недокопировались с последней операции if. Может, неправильно данные сохраняются в хранилище данных? P.s.2. - добавил картинку схемы работы макроса в программе.

Схема

11
  • Используйте ПОЛНУЮ спецификацию для ВСЕХ объектов (особенно Cells и Range, Rows и Columns). Строить, начиная с ThisWorkbook.
    – Akina
    14 фев 2020 в 12:21
  • перестроил добавив везде thisworkbook но результат тот же 14 фев 2020 в 12:26
  • Значит, добавляйте операторы сброса трассировки в файл и смотрите, на каком операторе и при каких значениях останавливается.
    – Akina
    14 фев 2020 в 12:32
  • А ещё - мне лично не нравится присвоение объектов без использования оператора Set.
    – Akina
    14 фев 2020 в 12:33
  • Range("a17:y300") = "" - вот откуда будет взят этот Range? ThisWorkbook.Sheets("Банк").Range(Cells(Z, 3), Cells(Z, 5)).Copy - откуда будут взяты эти Cells?
    – Akina
    14 фев 2020 в 12:34

1 ответ 1

0
Public Sub HHHH()

Dim LastRow, LastRow2, Lastcolumn, LastRow3, Lastcolumn2, LastRow4, Lastcolumn3 As Long
Dim a As Long
Dim Rw, Rw2, Rw3, Rw4, Rw5 As Long

ThisWorkbook.Sheets("Неделя").Range("a17:y300") = ""
a = ThisWorkbook.Sheets("Неделя").Cells(2, 2)
LastRow = ThisWorkbook.Sheets("Банк").Cells(Rows.Count, 1).End(xlUp).Row
LastRow2 = ThisWorkbook.Sheets("Поступления").Cells(Rows.Count, 1).End(xlUp).Row
Lastcolumn = ThisWorkbook.Sheets("Поступления").Cells(1, Columns.Count).End(xlToLeft).Column
LastRow3 = ThisWorkbook.Sheets("Затраты").Cells(Rows.Count, 1).End(xlUp).Row
Lastcolumn2 = ThisWorkbook.Sheets("Затраты").Cells(1, Columns.Count).End(xlToLeft).Column
LastRow4 = ThisWorkbook.Sheets("Счета").Cells(Rows.Count, 1).End(xlUp).Row
Lastcolumn3 = ThisWorkbook.Sheets("Счета").Cells(1, Columns.Count).End(xlToLeft).Column
      Application.ScreenUpdating = False
       ThisWorkbook.Sheets("Банк").Activate
     With ThisWorkbook.Sheets("Неделя")
        Rw = ThisWorkbook.Sheets("Неделя").Cells(Rows.Count, 1).End(xlUp).Row + 1
        For i = 1 To LastRow
            If  ThisWorkbook.Sheets("Банк").Cells(i, 13) = a And  ThisWorkbook.Sheets("Банк").Cells(i, 2) > 0 Then
               ThisWorkbook.Sheets("Банк").Range(ThisWorkbook.Sheets("Банк").Cells(i, 1), ThisWorkbook.Sheets("Банк").Cells(i, 2)).Copy
               ThisWorkbook.Sheets("Неделя").Cells(Rw, 1).PasteSpecial xlPasteValues
               ThisWorkbook.Sheets("Банк").Range(ThisWorkbook.Sheets("Банк").Cells(i, 4), ThisWorkbook.Sheets("Банк").Cells(i, 5)).Copy
               ThisWorkbook.Sheets("Неделя").Cells(Rw, 3).PasteSpecial xlPasteValues
               ThisWorkbook.Sheets("Банк").Cells(i, 19).Copy
               ThisWorkbook.Sheets("Неделя").Cells(Rw, 5).PasteSpecial xlPasteValues
                Rw = Rw + 1
            End If
        Next
      End With
      With ThisWorkbook.Sheets("Неделя")
        Rw2 = ThisWorkbook.Sheets("Неделя").Cells(Rows.Count, 11).End(xlUp).Row + 1
        For Z = 1 To LastRow
            If  ThisWorkbook.Sheets("Банк").Cells(Z, 13) = a And  ThisWorkbook.Sheets("Банк").Cells(Z, 3) > 0 Then
               ThisWorkbook.Sheets("Банк").Cells(Z, 1).Copy
               ThisWorkbook.Sheets("Неделя").Cells(Rw2, 11).PasteSpecial xlPasteValues
               ThisWorkbook.Sheets("Банк").Range(Cells(Z, 3), Cells(Z, 5)).Copy
               ThisWorkbook.Sheets("Неделя").Cells(Rw2, 12).PasteSpecial xlPasteValues
               ThisWorkbook.Sheets("Банк").Cells(Z, 22).Copy
               ThisWorkbook.Sheets("Неделя").Cells(Rw2, 15).PasteSpecial xlPasteValues
                Rw2 = Rw2 + 1
            End If
        Next
       End With
       With ThisWorkbook.Sheets("Неделя")
         ThisWorkbook.Sheets("Поступления").Activate
        Rw3 = ThisWorkbook.Sheets("Неделя").Cells(Rows.Count, 6).End(xlUp).Row + 1
        For in1 = 1 To Lastcolumn
            For in2 = 2 To LastRow2
            If ThisWorkbook.Sheets("Поступления").Cells(1, in1) = a And ThisWorkbook.Sheets("Поступления").Cells(in2, in1) > 0 Then
               ThisWorkbook.Sheets("Поступления").Cells(in2, in1).Copy
               ThisWorkbook.Sheets("Неделя").Cells(Rw3, 8).PasteSpecial xlPasteValues
               ThisWorkbook.Sheets("Поступления").Range(ThisWorkbook.Sheets("Поступления").Cells(in2, 1), ThisWorkbook.Sheets("Поступления").Cells(in2, 2)).Copy
               ThisWorkbook.Sheets("Неделя").Cells(Rw3, 6).PasteSpecial xlPasteValues
                Rw3 = Rw3 + 1
            End If
            Next
        Next
      End With
      With ThisWorkbook.Sheets("Неделя")
               ThisWorkbook.Sheets("Затраты").Activate
        Rw4 = ThisWorkbook.Sheets("Неделя").Cells(Rows.Count, 18).End(xlUp).Row + 1
        For out1 = 1 To Lastcolumn2
            For out2 = 2 To LastRow3
            If ThisWorkbook.Sheets("Затраты").Cells(1, out1) = a And ThisWorkbook.Sheets("Затраты").Cells(out2, out1) > 0 Then
               ThisWorkbook.Sheets("Затраты").Cells(out2, out1).Copy
               ThisWorkbook.Sheets("Неделя").Cells(Rw4, 21).PasteSpecial xlPasteValues
               ThisWorkbook.Sheets("Затраты").Cells(out2, 1).Copy
               ThisWorkbook.Sheets("Неделя").Cells(Rw4, 18).PasteSpecial xlPasteValues
               ThisWorkbook.Sheets("Затраты").Cells(out2, 3).Copy
               ThisWorkbook.Sheets("Неделя").Cells(Rw4, 20).PasteSpecial xlPasteValues
                Rw4 = Rw4 + 1
            End If
            Next
        Next
         End With
      With ThisWorkbook.Sheets("Неделя")
               ThisWorkbook.Sheets("Счета").Activate
        Rw5 = ThisWorkbook.Sheets("Неделя").Cells(Rows.Count, 24).End(xlUp).Row + 1
        For bill1 = 1 To Lastcolumn2
            For bill2 = 2 To LastRow3
            If ThisWorkbook.Sheets("Счета").Cells(1, bill1) = a And ThisWorkbook.Sheets("Счета").Cells(bill2, bill1) > 0 Then
               ThisWorkbook.Sheets("Счета").Cells(bill2, bill1).Copy
               ThisWorkbook.Sheets("Неделя").Cells(Rw5, 25).PasteSpecial xlPasteValues
               ThisWorkbook.Sheets("Счета").Cells(bill2, 2).Copy
               ThisWorkbook.Sheets("Неделя").Cells(Rw5, 24).PasteSpecial xlPasteValues

                Rw5 = Rw5 + 1
            End If
            Next
        Next
    End With

 ThisWorkbook.Sheets("Неделя").Activate
 Application.ScreenUpdating = True
End Sub    

Загвоздка была в назначении IF и дальше cells нужен был полный адрес

введите сюда код

Ваш ответ

Нажимая на кнопку «Отправить ответ», вы соглашаетесь с нашими условиями использования и подтверждаете, что прочитали и поняли наши политику конфиденциальности и нормы поведения.

Всё ещё ищете ответ? Посмотрите другие вопросы с метками или задайте свой вопрос.