worksheet_change如何实现限定条件的多功能复制粘贴

chen68178

本人由于水平有限，接触VBA时间不多，只是在使用Excel 工作表时发现VBA能实现的功能更强大。开始对VBA加深学习与探讨，虽然有查找了一些资料，但仍无法搞定各种功能，所以请高手和老师们帮忙赐教！


数据关系：（D2：K3）对应（AG2：AI2）单元格的复制，触发单元格为（H3）,条件项为(K2),当(K2)值大于0时才会触发复制，（D2，I3，I2）对应复制在（AG2，AI3，AI2）单元格内；以下的对应关系与上面相同：（D4：K5）对应（AG3：AI3）的复制、（D6：K7）对应（AG4：AI4）的复制。                      希望实现的功能是:
(1),"H3"的数值刷新时条件项(K2)值大于0时才能触发复制事件。                  
(2),但是“重点是”已经复制过的内容中“数值相同的”不再进行复制，只复制数值改变的单元格(为了提高执行速度，低配办公电脑执行复杂运算时速度很慢的)。
本表VBA代码遇到的问题：                                               
当（AG2，AH2，AI2）单元格的内容全部不相同时（或者为空时），代码能执行复制，但再次刷新"H3"单元格时无法再次触发事件把"D2"单元格改变后的数值复制到"AI2"上。而在刷新"H5"单元格时，由于没有设置“相同值不再复制”的条件，而把（AG3，AH3，AI3）内容全部更新了一遍。所以实现不了本人希望实现 的功能。

chen68178

在线等，希望高手帮忙，谢谢！！

chen68178

数据关系：
（D2：K3）对应（AG2：AI2）单元格的复制，触发单元格为（H3）,条件项为(K2),当(K2)值大于0时才会触发复制，（D2，I3，I2）对应复制在（AG2，AI3，AI2）单元格内；以下的对应关系与上面相同：（D4：K5）对应（AG3：AI3）的复制、（D6：K7）对应（AG4：AI4）的复制。
  希望实现的功能是:
(1),"H3"的数值刷新时条件项(K2)值大于0时才能触发复制事件。                  
(2),但是“重点是”已经复制过的内容中“数值相同的”不再进行复制，只复制数值改变的单元格(为了提高执行速度，低配办公电脑执行复杂运算时速度很慢的)。
  本表VBA代码遇到的问题：                                               
当（AG2，AH2，AI2）单元格的内容全部不相同时（或者为空时），代码能执行复制，但再次刷新"H3"单元格时无法再次触发事件把"D2"单元格改变后的数值复制到"AI2"上。而在刷新"H5"单元格时，由于没有设置“相同值不再复制”的条件，而把（AG3，AH3，AI3）内容全部更新了一遍。所以实现不了本人希望实现 的功能。

自制VBA代码如下：帮忙看看出了什么问题？谢谢！

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Rows.Count > 1 Then
Exit Sub
Else
If Target.Row = 3 And Target.Count = 1 And Target.Column = 8 Then
If Target.Address <> "h3" And Range("k2") > 0 Then
'Else
           If Range("ag2").Value <> Range("d2").Value Then
           Range("ag2") = Range("d2")
'Else
        If Range("ah2") <> Range("i3") Then
        Range("ah2") = Range("i3")
'Else
      If Range("ai2") <> Range("i2") Then
      Range("ai2") = Range("i2")
End If
End If
End If
End If
   Else
If Target.Row = 5 And Target.Count = 1 And Target.Column = 8 Then
   If Target.Address <> "h5" And Range("k4") > 0 Then
           Range("ag3") = Range("d4")
        Range("ah3") = Range("i5")
      Range("ai3") = Range("i4")
   End If
   Else
If Target.Row = 7 And Target.Count = 1 And Target.Column = 8 Then
   If Target.Address <> "h7" And Range("k6") > 0 Then
           Range("ag4") = Range("d6")
        Range("ah4") = Range("i7")
      Range("ai4") = Range("i6")
End If
Else
   If Target.Address <> "h3" And Range("k2") = 0 Then
         Range("ag2") = Range("d2")
       Range("ah2") = Range("i3")
      Range("ai2") = Range("i2")
Else
If Target.Row = 6 Then
   If Target.Address <> "$k$6" Then
   If Target = 0 And Target.Value <> "" Then
         Range("H7:I7") = 0
    End If
  End If
End If
End If
   Application.EnableEvents = True
End If
End If
End If
End If


End Sub

chen68178

大神们来帮个忙吧！！

数据关系：
（D2：K3）对应（AG2：AI2）单元格的复制，触发单元格为（H3）,条件项为(K2),当(K2)值大于0时才会触发复制，（D2，I3，I2）对应复制在（AG2，AI3，AI2）单元格内；以下的对应关系与上面相同：（D4：K5）对应（AG3：AI3）的复制、（D6：K7）对应（AG4：AI4）的复制。
  希望实现的功能是:
(1),"H3"的数值刷新时条件项(K2)值大于0时才能触发复制事件。                  
(2),但是“重点是”已经复制过的内容中“数值相同的”不再进行复制，只复制数值改变的单元格(为了提高执行速度，低配办公电脑执行复杂运算时速度很慢的)。
  本表VBA代码遇到的问题：                                               
当（AG2，AH2，AI2）单元格的内容全部不相同时（或者为空时），代码能执行复制，但再次刷新"H3"单元格时无法再次触发事件把"D2"单元格改变后的数值复制到"AI2"上。而在刷新"H5"单元格时，由于没有设置“相同值不再复制”的条件，而把（AG3，AH3，AI3）内容全部更新了一遍。所以实现不了本人希望实现 的功能。
_试算表-.zip (31.83 KB, 下载次数: 0)

2018-1-26 17:02 上传

点击文件名下载附件

自制VBA代码如下：帮忙看看出了什么问题？谢谢！

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Rows.Count > 1 Then
Exit Sub
Else
If Target.Row = 3 And Target.Count = 1 And Target.Column = 8 Then
If Target.Address <> "h3" And Range("k2") > 0 Then
'Else
           If Range("ag2").Value <> Range("d2").Value Then
           Range("ag2") = Range("d2")
'Else
        If Range("ah2") <> Range("i3") Then
        Range("ah2") = Range("i3")
'Else
      If Range("ai2") <> Range("i2") Then
      Range("ai2") = Range("i2")
End If
End If
End If
End If
   Else
If Target.Row = 5 And Target.Count = 1 And Target.Column = 8 Then
   If Target.Address <> "h5" And Range("k4") > 0 Then
           Range("ag3") = Range("d4")
        Range("ah3") = Range("i5")
      Range("ai3") = Range("i4")
   End If
   Else
If Target.Row = 7 And Target.Count = 1 And Target.Column = 8 Then
   If Target.Address <> "h7" And Range("k6") > 0 Then
           Range("ag4") = Range("d6")
        Range("ah4") = Range("i7")
      Range("ai4") = Range("i6")
End If
Else
   If Target.Address <> "h3" And Range("k2") = 0 Then
         Range("ag2") = Range("d2")
       Range("ah2") = Range("i3")
      Range("ai2") = Range("i2")
Else
If Target.Row = 6 Then
   If Target.Address <> "$k$6" Then
   If Target = 0 And Target.Value <> "" Then
         Range("H7:I7") = 0
    End If
  End If
End If
End If
   Application.EnableEvents = True
End If
End If
End If
End If


End Sub

蓝桥玄霜

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. If Target.Count > 1 Then Exit Sub
   
3. If Target.Column <> 8 Then Exit Sub
   
4. 
   
5. 
   
6. If Target.Row = 3 Then
   
7.     If Range("k2") > 0 Then
   
8.         If Range("ag2").Value <> Range("d2").Value Then
   
9.            Range("ag2") = Range("d2").Value
   
10.         End If
    
11.         If Range("ah2") <> Range("i3").Value Then
    
12.             Range("ah2") = Range("i3").Value
    
13.         End If
    
14.         If Range("ai2") <> Range("i2").Value Then
    
15.             Range("ai2") = Range("i2").Value
    
16.         End If
    
17.     End If
    
18. ElseIf Target.Row = 5 Then
    
19.    If Range("k4") > 0 Then
    

复制代码

要这样写，你的代码中都有重复判断的情况，限定了H列和行以后就不需要再去判断单元格地址了，而且地址写法要这样的：
If Target.Address <> "$A$1" Then
要大写字母，要加"$"

chen68178

蓝桥玄霜 发表于 2018-1-27 11:10
要这样写，你的代码中都有重复判断的情况，限定了H列和行以后就不需要再去判断单元格地址了，而且地址写 ...

感谢老师的指教！你的方法可行。而我自已常试把复制的次序倒过来也可行，把数值必不相司的单元先行复制，当然我基础薄弱是一定的了，哈哈！那原来的问题就是因为地址写错造成的吗，还是判断的情况都是呢？
下面还有一个代码请教老师您的：
数据关系：                                                                           
   触发单元格为（H9）,条件项为(K2),当(K2)值（=0）时才会触发复制，分别与（AG2，AG3，AG4）内容作为查找对象。举例：在（D2：D7）单元格中查到与（AG3）相同的数值，得出（000550）这个数值在（D列）中的行号（目前是在第（4）行，但下次就会变动行号或者消失的），以此行号（4）为基础，在（H列）对应（此行号+1行），（也就是H4加一行，变为H5单元格并把（AI3）的数值复制进（H5）格内）。                                                               本表VBA代码遇到的问题：                                                                                                        
多次调试都出现定义不正确，查找方式错误等情况。 _试算表- (恢复的).zip (29.46 KB, 下载次数: 1)

2018-1-28 19:24 上传

点击文件名下载附件

'Private Sub Worksheet_Change(ByVal Target As Range)

'If Target.Count > 1 Then Exit Sub
'If Target.Column <> 8 Then Exit Sub

'   If Target.Row = 9 Then
'    If Range("k2") > 0 Then
'  End If
'  End If
'For Each Rng In Range("d2:d7")
'    If Rng = Range("AG3") Then
'        a = Rng.Row
'    End If
'Next
'MsgBox "行号为" & a & "-" & "列号为" & b
'End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

  If Target.Count > 1 Then Exit Sub
  If Target.Column <> 8 Then Exit Sub
    If Target.Row = 9 Then
    If Range("k2") > 0 Then
  End If
  End If

'Dim findcell%
'Dim fr%
'Set findcell = Range("d2:d7").Find(Range("AG3").Value)
'Set findcell = Columns("d2:d7").Find("00550", LookIn:=xlValues, lookat:=xlWhole).Row
'If Not findcell Is Nothing Then
'fr = findcell.Row
    Dim rng As Range, rngSearch As Range
    Dim vl As String
    Set rng = Range("d2:d7")
    vl = "00550"
    Set rngSearch = rng.Find(vl)
    If Not rngSearch Is Nothing Then
    r = rngSearch.Row
Cells(r, 8) = Cells(3, 35).Value

End If
End Sub

'e = Columns(2).Find("60", SearchDirection:=2).Row


'Set findcell = Columns("c").Find("宁波", LookAt:=xlPart)
'If Not findcell Is Nothing Then