Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Заполнение диапазона макросом из другого листа
 
#1
28.04.2020 15:25:32
Здраствуйте! Есть макрос который заполняет ячейки на основании другого листа. Но делать надо все по-одному. Что надо изменить что-бы протягивая или копируя значения заполнялись ячейки? (А не только первая).

Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("E2:E10000")) Is Nothing Then
        If Range("E" & Target.Row) <> "" Then
           i = Cells(Split(Target.Address, "$")(2), 2)
           With Sheets("Лист1")
                For s = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
                    If .Cells(s, 2) = i Then
                       .Cells(s, 5) = "Гараж"
                       .Cells(s, 3) = ""
                       .Cells(s, 4) = ""
                    End If
                Next
          End With
        End If
    End If
end sub
 
 
 
#2
28.04.2020 16:28:47
Если хотите чтобы это происходило автоматически - то только по одному. А если сразу всех - тогда вручную запускать макрос. Можно конечно поставить на активацию листа или еще там чего, но это уже извращение.
 
 
 
#3
28.04.2020 16:36:12
Может так?
Код
Private Sub Worksheet_Change(ByVal Target As Range)
'If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("E2:E10000")) Is Nothing Then
        Dim c As Range
        For Each c In Target.Cells
            If Range("E" & c.Row) <> "" Then   '???
               i = Cells(Split(c.Address, "$")(2), 2)
               With Sheets("Лист1")
                    For s = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
                        If .Cells(s, 2) = i Then
                           .Cells(s, 5) = "Гараж"
                           .Cells(s, 3) = ""
                           .Cells(s, 4) = ""
                        End If
                    Next
              End With
            End If
        Next
    End If
End Sub
 
 
 
#4
28.04.2020 16:57:05
или как-то так
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Range
    On Error Resume Next
    With Sheets("Лист1").UsedRange.Columns("B")
        For Each r In Intersect(Me.UsedRange, Me.[E:F], Target.EntireRow).Rows
             If Err.Number = 91 Then Exit For
             With .Find(r.Offset(, 2 - r.Column).Cells(1), .Cells(1), xlValues, xlWhole)
                If r.Cells(1) <> "" Then
                    With .Offset(, 1).Resize(, 3)
                        .ClearContents
                        .Cells(, 3) = "Гараж"
                    End With
                Else: Select Case r.Cells(2)
                    Case "Отпуск", "Рейс"
                        .Offset(, 1).Resize(, 3) = Application.Index(r.EntireRow, Array(3, 4, 6))
                    End Select
                End If
             End With
        Next
    End With
End Sub
Изменено: Андрей Лящук - 28.04.2020 18:25:04
 
 
 
#5
28.04.2020 17:14:14
Значит я ошибался ))
 
 
 
#6
29.04.2020 15:05:14
МатросНаЗебре, Андрей Лящук, Андрей_26,  спасибо!
 
 
 
Страницы: 1
Наверх