Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос копирования значений при изменении в ячейке
 
#1
17.05.2016 17:31:42
Есть диапазон ячеек, например A1:A10, если значение в одной ячейке например А3 изменилось, то макрос копирует только значение этой ячейки например в В3 и т.д. если изменилось значение в А6, копируется значение в В6. Возможно ли такое? Спасибо  
 
 
 
#2
17.05.2016 18:02:50
Копирует значение которое было раньше?
 
 
 
#3
17.05.2016 18:08:25
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub 'выделено больше одной ячейки
    If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
        Cells(Target.Row, 2) = Target
    End If
End Sub
 
 
 
#4
17.05.2016 19:30:20
Цитата
U_M0KRH написал: Копирует значение которое было раньше?
Нет, просто новое значение, без формул и т.д.
 
 
 
#5
17.05.2016 19:43:47
Kuzmich, код подходит спасибо, а что если на одном листе у меня 2 столбца которые надо копировать, и еще как перенести место копирования со столбца В например на столбец G
 
 
 
#6
17.05.2016 20:00:31
Cells(Target.Row, 2) 2-это столбец В, для столбцаG-7
 
 
 
#7
17.05.2016 20:01:25
Спасибо, а как быть если у меня два столбца для копирования? например А в В и С в D

И еще как объединить с этим макросом?:
Код
Option Explicit
Public k  As Long

Private Sub Worksheet_Change(ByVal Target As Range)   
Dim myControlRange As Range
 'назначаем конролируемую ячейку при изменении которой бдет запускаться макрос
 'и с этим занчением будут сравниваться данные
  Set myControlRange = Range("A1:A12")
 
  'пропускаем ошибки
  On Error Resume Next
   
  If Selection.Cells.Count > 1 Then Exit Sub
  
   If Not Intersect(Target, myControlRange) Is Nothing Then
          If IsNumeric(Target.Value) Then
               
               Application.EnableEvents = False
                    Target.Value = k + Target.Value
               Application.EnableEvents = True
            End If
     End If     
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 If Selection.Cells.Count > 1 Then Exit Sub
  
    If Not Intersect(Target, Range("A1:A12")) Is Nothing Then
        k = Target.Value
        'Debug.Print k
    End If
End Sub
Изменено: behost - 17.05.2016 21:31:21
 
 
 
#8
17.05.2016 20:26:37
Цитата
например А в В и С в D
Добавьте в код
Код
Cells(Target.Row, 2) = Target
Cells(Target.Row, 4) = Cells(Target.Row, 3)
 
 
 
#9
17.05.2016 20:35:36
behost, код следует оформлять соответствующим тегом. И копировать при русской раскладке клавиатуры. Исправьте.
 
 
 
#10
17.05.2016 20:37:35
Цитата
Kuzmich написал: Добавьте в код
У меня получается копировать сразу в два столбца, но мне надо из двух в два, например из ячейки А1 в С1, и из В1 в D1  
 
 
 
#11
17.05.2016 20:41:06
Цитата
behost написал: Это подходит спасибо, а что если...И еще как...Спасибо, а как быть если ...
Вот почему сразу не задать ВЕСЬ (точнее НУЖНЫЙ) вопрос? Тема растянулась на 10 сообщений и 3 часа. И не факт что это все "если"...
Согласие есть продукт при полном непротивлении сторон
 
 
 
#12
17.05.2016 20:41:22
Код
Cells(Target.Row, 3) = Target
Cells(Target.Row, 4) = Cells(Target.Row, 2)
 
 
 
#13
17.05.2016 20:57:54
Я добавил у меня из А1 копируется в С1, но надо что бы и из B1 вводимое значение копировалось в D1, может я не туда код добавил, получилось так:
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub 'выделено больше одной ячейки
    If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
        Cells(Target.Row, 3) = Target
        Cells(Target.Row, 4) = Cells(Target.Row, 2)
    End If
End Sub
Изменено: behost - 17.05.2016 21:32:11
 
 
 
#14
17.05.2016 21:06:44
Добавляйте ещё одну проверку:
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub 'выделено больше одной ячейки
    If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
        Cells(Target.Row, 3) = Target
        Cells(Target.Row, 4) = Cells(Target.Row, 2)
    End If
    If Not Intersect(Target, Range("B1:B10")) Is Nothing Then
        Cells(Target.Row, 4) = Target
    End If
End Sub
 
 
 
#15
17.05.2016 21:08:35
Огромное спасибо, то что надо!
 
 
 
#16
17.05.2016 21:12:04
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub 'выделено больше одной ячейки
    If Not Intersect(Target, Range("A1:B10")) Is Nothing Then
        If Target.Column = 1 Then
          Cells(Target.Row, 3) = Target
        Else
          Cells(Target.Row, 4) = Target
        End If
    End If
End Sub
 
 
 
#17
17.05.2016 21:29:00
Все работает, а если ячейка с которой надо скопировать значения это ссылка, тогда не будет работать макрос?
 
 
 
Страницы: 1
Наверх