一会员积分表求完善

cj113989

在B2输入编号或简码，引用sheet1合条件的。本次消费和备注可以修改,并返回sheet1保存。问题：如果在本次消费中，输入小于0的数字，回车后该列内容同时保存在sheet3中。保存不覆盖，全部依次记录。

xdragon

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim arr, arr1
   
3.     Dim iR&, x&, i&, n&, j&, endrow&
   
4.     Dim T As String
   
5.     If Target.Address = "$B$1" Then
   
6.         T = Range("b1").Value
   
7.         If Len(T) = 4 Then j = 1 Else j = 2
   
8.         With Sheets("sheet1")
   
9.             iR = .Range("A65536").End(xlUp).Row
   
10.             arr = .Range("A2:l" & iR).Value
    
11.             ReDim arr1(1 To UBound(arr), 1 To UBound(arr, 2))
    
12.             For x = 1 To UBound(arr)
    
13.                 If arr(x, j) = T Then
    
14.                     i = i + 1
    
15.                     For n = 1 To 12
    
16.                         arr1(i, n) = arr(x, n)
    
17.                     Next n
    
18.                 End If
    
19.             Next x
    
20.         End With
    
21.         Range("A3").Resize(UBound(arr1), UBound(arr1, 2)) = arr1
    
22.     End If
    
23.     If Target.Row > 2 And Target.Column = 5 And Target.Count = 1 Then
    
24.       Cells(Target.Row, 6) = Cells(Target.Row, 6) + Target.Value
    
25.       Cells(Target.Row, 8) = Cells(Target.Row, 8) + Target.Value
    
26.       If Target.Value > 0 Then
    
27.         With Sheets("sheet1")
    
28.             For x = 1 To .Range("A65536").End(xlUp).Row
    
29.                 If .Cells(x, 1) = Cells(Target.Row, 1) Then
    
30.                     .Cells(x, 5) = Cells(Target.Row, 5).Value
    
31.                     .Cells(x, 6) = Cells(Target.Row, 6).Value
    
32.                     .Cells(x, 8) = Cells(Target.Row, 8).Value
    
33.                     .Cells(x, 12) = Cells(Target.Row, 12).Value
    
34.                 End If
    
35.             Next x
    
36.          End With
    
37.       Else
    
38.          With Sheets("Sheet3")
    
39.              endrow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
    
40.              .Range("A" & endrow & ":L" & endrow).Value = Range("A" & Target.Row & ":L" & Target.Row).Value
    
41.          End With
    
42.       End If
    
43.     End If
    
44.     If Target.Row > 2 And Target.Column = 12 And Target.Count = 1 Then
    
45.         With Sheets("sheet1")
    
46.             For x = 1 To .Range("A65536").End(xlUp).Row
    
47.                 If .Cells(x, 1) = Cells(Target.Row, 1) Then
    
48.                     .Cells(x, 12) = Cells(Target.Row, 12).Value
    
49.                 End If
    
50.             Next x
    
51.         End With
    
52.     End If
    
53. End Sub
    

复制代码

不知道是不是楼主想要的