[已解决]请各位师傅帮忙解决这个分类的难题

qiongmei

我附件上有三个表格，在录入表格内a列和b列，我录入相关的数据，我希望得到一个代码，当录入表格内b列为正数的，a列和b列同行的数据会进入奖励表格列m列和n列内，当录入表格b列为负数的时候，a列和b列同行的数据会进入考核表格格列m列和n列内，现在的奖励和考核表就是我希望得到的结果，谢谢高手师傅的帮忙。

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-3-25 14:59

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. If Target.Count > 1 Then Exit Sub
   
3. If Target.Column <> 2 Then Exit Sub
   
4. If Target.Row < 4 Then Exit Sub
   
5. If Target = "" Then Exit Sub
   
6. If Target > 0 Then
   
7.   Sheets("奖励表").[m65536].End(3).Offset(1).Resize(1, 2) = Target.Offset(, -1).Resize(1, 2).Value
   
8. ElseIf Target < 0 Then
   
9.   Sheets("考核表").[m65536].End(3).Offset(1).Resize(1, 2) = Target.Offset(, -1).Resize(1, 2).Value
   
10. End If
    
11. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. If Target.Count > 1 Then Exit Sub
   
3. If Target.Column <> 2 Then Exit Sub
   
4. If Target.Row < 4 Then Exit Sub
   
5. If Target = "" Then Exit Sub
   
6. If Target > 0 Then
   
7.   Sheets("奖励表").[m65536].End(3).Offset(1).Resize(1, 2) = Target.Offset(, -1).Resize(1, 2).Value
   
8. ElseIf Target < 0 Then
   
9.   Sheets("考核表").[m65536].End(3).Offset(1).Resize(1, 2) = Target.Offset(, -1).Resize(1, 2).Value
   
10. End If
    
11. End Sub

复制代码

大灰狼1976

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. If Target.Count > 1 Then Exit Sub
   
3. If Target.Column <> 2 Then Exit Sub
   
4. If Target.Row < 4 Then Exit Sub
   
5. If Target = "" Then Exit Sub
   
6. If Target > 0 Then
   
7.   Sheets("奖励表").[m65536].End(3).Offset(1).Resize(1, 2) = Target.Offset(, -1).Resize(1, 2).Value
   
8. ElseIf Target < 0 Then
   
9.   Sheets("考核表").[m65536].End(3).Offset(1).Resize(1, 2) = Target.Offset(, -1).Resize(1, 2).Value
   
10. End If
    
11. End Sub

复制代码

qiongmei

谢谢大灰狼1976师傅，但是能不能再帮我修改下，您现在使用的回车就出数据的模式，能不能改成我全部输入完后通过按钮再执行的模式，就是使用sub的模式，麻烦您再修改下行吗，再次谢谢您了。

大灰狼1976

1. Sub aaa()
   
2. Dim i&, rng As Range, rng1 As Range
   
3. For i = 4 To [a65536].End(3).Row
   
4.   If Cells(i, 2) > 0 Then
   
5.     If rng Is Nothing Then Set rng = Cells(i, 1).Resize(, 2) Else Set rng = Union(rng, Cells(i, 1).Resize(, 2))
   
6.   ElseIf Cells(i, 2) < 0 Then
   
7.     If rng1 Is Nothing Then Set rng1 = Cells(i, 1).Resize(, 2) Else Set rng1 = Union(rng1, Cells(i, 1).Resize(, 2))
   
8.   End If
   
9. Next i
   
10. rng.Copy Sheets("奖励表").[m65536].End(3).Offset(1)
    
11. rng1.Copy Sheets("考核表").[m65536].End(3).Offset(1)
    
12. End Sub

复制代码

qiongmei

谢谢大灰狼1976师傅，你提供的代码正是我所希望的

sscchh123

学习了