Объединение похожих кодов VBA

Дата: Пятница, 22.11.2024, 10:19 | Сообщение № 1

Группа: Пользователи

Ранг: Новичок

Сообщений: 33

Репутация: 0 ±

Замечаний: 0% ±

2020

Необходимо объединить два кода разница только в одной строке, в которой либо по зеленому либо по красному фону заливки нужно выполнить одно и тоже условие
может кто знает? Так как плохо понимаю пытался не вышло

[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub

Dim iLast As Long
iLast = Me.Columns("A").Find(what:="*", _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
' Debug.Print iLast

If Not Intersect(Target, Range("G3:G" & iLast)) Is Nothing Then

If Target.Offset(0, 1).DisplayFormat.Interior.Color = RGB(255, 0, 0) Then- [b]Разница только в этом

With ThisWorkbook.Worksheets("ÖÇË")

Dim lr As Long
lr = .Columns("F").Find(what:="*", _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
' Debug.Print lr
.Cells(lr + 1, 1) = Cells(Target.Row, 1) ' A
.Cells(lr + 1, 2) = Cells(Target.Row, 2) ' B
.Cells(lr + 1, 3) = Cells(Target.Row, 3) ' C
.Cells(lr + 1, 4) = Cells(Target.Row, 4) ' D
.Cells(lr + 1, 5) = Cells(Target.Row, 7) ' E
.Cells.Columns.AutoFit
End With

End If

End If

End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub

Dim iLast As Long
iLast = Me.Columns("A").Find(what:="*", _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
' Debug.Print iLast

If Not Intersect(Target, Range("G3:G" & iLast)) Is Nothing Then

If Target.Offset(0, 1).DisplayFormat.Interior.Color = RGB(153, 204, 0) Then - [b]Разница только в этом

With ThisWorkbook.Worksheets("ÖÇË")

Dim lr As Long
lr = .Columns("F").Find(what:="*", _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
' Debug.Print lr
.Cells(lr + 1, 1) = Cells(Target.Row, 1) ' A
.Cells(lr + 1, 2) = Cells(Target.Row, 2) ' B
.Cells(lr + 1, 3) = Cells(Target.Row, 3) ' C
.Cells(lr + 1, 4) = Cells(Target.Row, 4) ' D
.Cells(lr + 1, 5) = Cells(Target.Row, 7) ' E
.Cells.Columns.AutoFit
End With

End If

End If

End Sub

[/vba]

Код

[/vba]DenchikZ

Сообщение отредактировал DenchikZ - Пятница, 22.11.2024, 10:21

СообщениеНеобходимо объединить два кода разница только в одной строке, в которой либо по зеленому либо по красному фону заливки нужно выполнить одно и тоже условие
может кто знает? Так как плохо понимаю пытался не вышло

[vba]

Код

[/vba]

Автор - DenchikZ
Дата добавления - 22.11.2024 в 10:19

doober

Дата: Пятница, 22.11.2024, 10:32 | Сообщение № 2

Группа: Друзья

Ранг: Ветеран

Сообщений: 983

Репутация: 340 ±

Замечаний: 0% ±

Excel 2010

[vba]

Код

    If Not Intersect(Target, Range("G3:G" & iLast)) Is Nothing Then

        If Target.Offset(0, 1).DisplayFormat.Interior.Color = RGB(255, 0, 0) Then

            With ThisWorkbook.Worksheets("OCE")
                Dim lr As Long
                lr = .Columns("F").Find(what:="*", _
                    LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
                ' Debug.Print lr
                .Cells(lr + 1, 1) = Cells(Target.Row, 1)    ' A
                .Cells(lr + 1, 2) = Cells(Target.Row, 2)    ' B
                .Cells(lr + 1, 3) = Cells(Target.Row, 3)    ' C
                .Cells(lr + 1, 4) = Cells(Target.Row, 4)    ' D
                .Cells(lr + 1, 5) = Cells(Target.Row, 7)    ' E
                .Cells.Columns.AutoFit
            End With
        ElseIf Target.Offset(0, 1).DisplayFormat.Interior.Color = RGB(153, 204, 0) Then

            With ThisWorkbook.Worksheets("OCE")

                Dim lr As Long
                lr = .Columns("F").Find(what:="*", _
                    LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
                .Cells(lr + 1, 1) = Cells(Target.Row, 1)    ' A
                .Cells(lr + 1, 2) = Cells(Target.Row, 2)    ' B
                .Cells(lr + 1, 3) = Cells(Target.Row, 3)    ' C
                .Cells(lr + 1, 4) = Cells(Target.Row, 4)    ' D
                .Cells(lr + 1, 5) = Cells(Target.Row, 7)    ' E
                .Cells.Columns.AutoFit
            End With
        End If
    End If

End If

[/vba]

[vba]

Код

[/vba]

doober

Сообщение

[vba]

Код

[/vba]

Автор - doober
Дата добавления - 22.11.2024 в 10:32

Дата: Пятница, 22.11.2024, 11:12 | Сообщение № 3

Группа: Пользователи

Ранг: Новичок

Сообщений: 33

Репутация: 0 ±

Замечаний: 0% ±

2020

doober, пробую но не работает

Дата: Пятница, 22.11.2024, 11:29 | Сообщение № 4

Группа: Админы

Ранг: Участник клуба

Сообщений: 2810

Репутация: 1184 ±

Замечаний: ±

начинал с Excel 4.0, видел 2.1

Немного оптимизну фрагмент кода doober:
[vba]

Код

    If Not Intersect(Target, Range("G3:G" & iLast)) Is Nothing Then

        Dim lr As Long, vColor
        vColor = Target.Offset(0, 1).DisplayFormat.Interior.Color

        If vColor = RGB(255, 0, 0) Or vColor = RGB(153, 204, 0) Then

            With ThisWorkbook.Worksheets("OCE")

                lr = .Columns("F").Find(what:="*", _
                    LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
                ' Debug.Print lr
                .Cells(lr + 1, 1) = Cells(Target.Row, 1)    ' A
                .Cells(lr + 1, 2) = Cells(Target.Row, 2)    ' B
                .Cells(lr + 1, 3) = Cells(Target.Row, 3)    ' C
                .Cells(lr + 1, 4) = Cells(Target.Row, 4)    ' D
                .Cells(lr + 1, 5) = Cells(Target.Row, 7)    ' E
                .Cells.Columns.AutoFit
            End With
        End If
    End If

[/vba]

Дата: Пятница, 22.11.2024, 11:59 | Сообщение № 5

Группа: Пользователи

Ранг: Новичок

Сообщений: 33

Репутация: 0 ±

Замечаний: 0% ±

2020

Gustav,Я вставляю в код но все равно не работает не продолжает базу данных на следующем листе а заменяет ее

Или что я не так делаю? Код ниже

[vba]

Код

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub

Dim iLast As Long
iLast = Me.Columns("A").Find(what:="*", _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
' Debug.Print iLast

If Not Intersect(Target, Range("G3:G" & iLast)) Is Nothing Then

Dim lr As Long, vColor
vColor = Target.Offset(0, 1).DisplayFormat.Interior.Color

If vColor = RGB(255, 0, 0) Or vColor = RGB(153, 204, 0) Then

With ThisWorkbook.Worksheets("OCE")

lr = .Columns("F").Find(what:="*", _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
' Debug.Print lr
.Cells(lr + 1, 1) = Cells(Target.Row, 1) ' A
.Cells(lr + 1, 2) = Cells(Target.Row, 2) ' B
.Cells(lr + 1, 3) = Cells(Target.Row, 3) ' C
.Cells(lr + 1, 4) = Cells(Target.Row, 4) ' D
.Cells(lr + 1, 5) = Cells(Target.Row, 7) ' E
.Cells.Columns.AutoFit
End With
End If
End If

[/vba]

Сообщение отредактировал DenchikZ - Пятница, 22.11.2024, 12:09

Дата: Пятница, 22.11.2024, 12:14 | Сообщение № 6

Группа: Админы

Ранг: Участник клуба

Сообщений: 2810

Репутация: 1184 ±

Замечаний: ±

начинал с Excel 4.0, видел 2.1

Цитата DenchikZ, 22.11.2024 в 11:59, в сообщении № 5 (

)

все равно не работает выбивает ошибку

На какой строке останавливается? А Вы название другого листа подправили? doober написал "OCE", потому что были кракозябры, я дальше подхватил. А у Вас-то там какое-то другое слово из 3 букв... Надо исправить!

P.S. Проверил Ваш код из предыдущего сообщения - всё работает! Но у меня в книге лист называется "OCE" латинскими буквами, как в коде.

Дата: Пятница, 22.11.2024, 12:22 | Сообщение № 7

Группа: Пользователи

Ранг: Новичок

Сообщений: 33

Репутация: 0 ±

Замечаний: 0% ±

2020

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

Дата: Пятница, 22.11.2024, 12:29 | Сообщение № 8

Группа: Админы

Ранг: Участник клуба

Сообщений: 2810

Репутация: 1184 ±

Замечаний: ±

начинал с Excel 4.0, видел 2.1

Цитата DenchikZ, 22.11.2024 в 12:22, в сообщении № 7 (

)

но не переносит строки с первого листа в лист второй а заменяет их

А Ваши первоначальные версии двух процедур, запущенные по отдельности, переносили всё правильно? Мы же ничего критичного от себя не добавили, просто перегруппировали Ваши строки.

Вы же сначала, наверное, разработали одну процедуру - для одного цвета, а потом ее скопировали во вторую, но с другим цветом. Так вот эта первая процедура, пока она была одна, работала правильно?

Если нет, то Вы тогда должны объяснить простыми словами что хотите сделать (т.е. написать "ТЗ"), а мы прикинем, как это можно воплотить в жизнь. Но в любом случае первоначальный вопрос по объединению двух процедур в одну считаю уже решенным.

Дата: Пятница, 22.11.2024, 12:44 | Сообщение № 9

Группа: Пользователи

Ранг: Новичок

Сообщений: 33

Репутация: 0 ±

Замечаний: 0% ±

2020

Gustav, файл прикрепляю, мне нужно если горит красный цвет или зеленый не важно что бы автоматически перекидывало на лист ЦЗЛ и велась база данных но почему то заменяется строка а не создается новая, когда было по одному цвету все работало! Триггером служат ячейка G, или если возможно в конце таблицы поставить столбик "проверить" где будет либо плюс либо минус, при установке "+" данные будут перекидываться на лист "ЦЗЛ" с листа "Склад"

К сообщению приложен файл: probuem2_0.xlsm (48.1 Kb)

Сообщение отредактировал DenchikZ - Пятница, 22.11.2024, 12:49

Дата: Пятница, 22.11.2024, 13:09 | Сообщение № 10

Группа: Админы

Ранг: Участник клуба

Сообщений: 2810

Репутация: 1184 ±

Замечаний: ±

начинал с Excel 4.0, видел 2.1

На листе "ЦЗЛ" строка вставки ищется по колонке F. Первая пустая ячейка в этой колонке - F4, т.е. четвертая строка. Вот он ее и никак не продлевает и пишет в одну и ту же. Заполните ячейку F4 - запишет в следующую (пятую) строку.

Дата: Пятница, 22.11.2024, 13:21 | Сообщение № 11

Группа: Пользователи

Ранг: Новичок

Сообщений: 33

Репутация: 0 ±

Замечаний: 0% ±

2020

Gustav, точно спасибо! Действительно, упустил из внимания! Опыта мало у меня! Спасибо большое!