同一工作表两个Worksheet_Change，求合并

jackyava

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$A$76" Then
    With Me.CommandButton1
        If [a76] = 1 Then
            .Caption = "男生": .BackColor = RGB(255, 0, 0)
        ElseIf [a76] = 0 Then
            .Caption = "女生": .BackColor = RGB(128, 128, 255)
         Else
         .Caption = vbNullString: .BackColor = RGB(240, 240, 240)
        End If
    End With
  End If
End Sub



Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$A$125" Then
    With Me.CommandButton1
        If [a125] = 1 Then
            .Caption = "男生": .BackColor = RGB(255, 0, 0)
        ElseIf [a125] = 0 Then
            .Caption = "女生": .BackColor = RGB(128, 128, 255)
         Else
         .Caption = vbNullString: .BackColor = RGB(240, 240, 240)
        End If
    End With
  End If
End Sub



附件
控件按钮根据数值变换名称ver.2.rar (15.75 KB, 下载次数: 28)

2016-5-30 17:35 上传

点击文件名下载附件

fxl447098457

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Dim d As Object
   
3. Set d = CreateObject("scripting.dictionary")
   
4.   Set d("$A$76") = Me.CommandButton1
   
5.   Set d("$A$125") = Me.CommandButton2
   
6.   If d.exists(Target.Address) Then
   
7.     With d(Target.Address)
   
8.         If Target = 1 Then
   
9.             .Caption = "男生": .BackColor = RGB(255, 0, 0)
   
10.         ElseIf Target = 0 Then
    
11.             .Caption = "女生": .BackColor = RGB(128, 128, 255)
    
12.          Else
    
13.          .Caption = vbNullString: .BackColor = RGB(240, 240, 240)
    
14.         End If
    
15.     End With
    
16.   End If
    
17. End Sub

复制代码

fxl447098457

代码已经贴出来了，等待审核。不知道EH是咋回事。动不动就要审核。。。

jackyava

fxl447098457 发表于 2016-5-31 19:29
代码已经贴出来了，等待审核。不知道EH是咋回事。动不动就要审核。。。

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$A$76" Then
    With Me.CommandButton1
        If [a76] = 1 Then
            .Caption = "男生": .BackColor = RGB(255, 0, 0)
        ElseIf [a76] = 0 Then
            .Caption = "女生": .BackColor = RGB(128, 128, 255)
         Else
         .Caption = vbNullString: .BackColor = RGB(240, 240, 240)
        End If
    End With
  End If
End Sub



Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$A$125" Then
    With Me.CommandButton1
        If [a125] = 1 Then
            .Caption = "主任": .BackColor = RGB(255, 0, 0)
        ElseIf [a125] = 0 Then
            .Caption = "科长": .BackColor = RGB(128, 128, 255)
         Else
         .Caption = vbNullString: .BackColor = RGB(240, 240, 240)
        End If
    End With
  End If
End Sub


要实现这样的效果，代码该怎么改？请老师赐教，谢谢
附件
控件按钮根据数值变换名称ver.3.rar (15.93 KB, 下载次数: 12)

2016-8-13 17:00 上传

点击文件名下载附件

skyzxh

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$A$76" Then
    With Me.CommandButton1
        If [a76] = 1 Then
            .Caption = "男生": .BackColor = RGB(255, 0, 0)
        ElseIf [a76] = 0 Then
            .Caption = "女生": .BackColor = RGB(128, 128, 255)
         Else
         .Caption = vbNullString: .BackColor = RGB(240, 240, 240)
        End If
    End With
  End If

  If Target.Address = "$A$125" Then
    With Me.CommandButton1
        If [a125] = 1 Then
            .Caption = "主任": .BackColor = RGB(255, 0, 0)
        ElseIf [a125] = 0 Then
            .Caption = "科长": .BackColor = RGB(128, 128, 255)
         Else
         .Caption = vbNullString: .BackColor = RGB(240, 240, 240)
        End If
    End With
  End If
End Sub

gcf0937

fxl447098457 发表于 2016-5-31 19:27

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i&, r1&, r2&, d, arr
    With Sheets("Sheet1")
        r1 = .Cells(.Rows.Count, 1).End(3).Row '取第一列中数据最大行号
        If Target.Column <> 1 Then Exit Sub '不是第一列,退出程序
        If Target.Row < 2 Or Target.Row > r1 Then Exit Sub '不是第2行到有数据的最大行,退出程序
    End With
    Set d = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet2")
        r2 = .Cells(.Rows.Count, 8).End(3).Row '取第8列中数据最大行号
        arr = .Range("G1:H" & r2).Value
        For i = 2 To UBound(arr)
            If arr(i, 2) <> "" Then d(arr(i, 2)) = arr(i, 1)
        Next
    End With
    With Sheets("Sheet1")
        If d.Exists(Target.Value) Then Target.Offset(0, 1).Value = d(Target.Value)
    End With
End Sub




Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i&, r1&, r2&, d, arr
    With Sheets("Sheet1")
        r1 = .Cells(.Rows.Count, 5).End(3).Row '取第一列中数据最大行号
        If Target.Column <> 5 Then Exit Sub '不是第一列,退出程序
        If Target.Row < 2 Or Target.Row > r1 Then Exit Sub '不是第2行到有数据的最大行,退出程序
    End With
    Set d = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet2")
        r2 = .Cells(.Rows.Count, 8).End(3).Row '取第8列中数据最大行号
        arr = .Range("G1:H" & r2).Value
        For i = 2 To UBound(arr)
            If arr(i, 2) <> "" Then d(arr(i, 2)) = arr(i, 1)
        Next
    End With
    With Sheets("Sheet1")
        If d.Exists(Target.Value) Then Target.Offset(0, 1).Value = d(Target.Value)
    End With
End Sub


以上代码如何合并，请大侠帮忙，我是个菜鸟，谢谢！

gcf0937

fxl447098457 发表于 2016-5-31 19:27

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i&, r1&, r2&, d, arr
    With Sheets("Sheet1")
        r1 = .Cells(.Rows.Count, 1).End(3).Row '取第一列中数据最大行号
        If Target.Column <> 1 Then Exit Sub '不是第一列,退出程序
        If Target.Row < 2 Or Target.Row > r1 Then Exit Sub '不是第2行到有数据的最大行,退出程序
    End With
    Set d = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet2")
        r2 = .Cells(.Rows.Count, 8).End(3).Row '取第8列中数据最大行号
        arr = .Range("G1:H" & r2).Value
        For i = 2 To UBound(arr)
            If arr(i, 2) <> "" Then d(arr(i, 2)) = arr(i, 1)
        Next
    End With
    With Sheets("Sheet1")
        If d.Exists(Target.Value) Then Target.Offset(0, 1).Value = d(Target.Value)
    End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i&, r1&, r2&, d, arr
    With Sheets("Sheet1")
        r1 = .Cells(.Rows.Count, 5).End(3).Row '取第一列中数据最大行号
        If Target.Column <> 5 Then Exit Sub '不是第一列,退出程序
        If Target.Row < 2 Or Target.Row > r1 Then Exit Sub '不是第2行到有数据的最大行,退出程序
    End With
    Set d = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet2")
        r2 = .Cells(.Rows.Count, 8).End(3).Row '取第8列中数据最大行号
        arr = .Range("G1:H" & r2).Value
        For i = 2 To UBound(arr)
            If arr(i, 2) <> "" Then d(arr(i, 2)) = arr(i, 1)
        Next
    End With
    With Sheets("Sheet1")
        If d.Exists(Target.Value) Then Target.Offset(0, 1).Value = d(Target.Value)
    End With
End Sub

大侠请帮助我如何把这两段进行合并,谢谢大侠!