Excel VBA - 自动分配组标记

Question

我有一个Excel表，有三列;

1. 学生姓名
2. 组ID
3. 集团转让商标

我想，当我分配一个标记一个组成员编写宏来自动分配痕组成员。任何人都可以请帮我怎么写一个宏来实现这个任务？

Answer 1

请注意，将此代码写入专用的Sheet模块中。

和修改如下常量：

Sheet1中：表名

表1：表名称中使用Worksheet_Change()事件作为在评论中提到

Private Sub Worksheet_Change(ByVal Target As Range) 
If ActiveSheet.Name = "Sheet1" Then 
    Application.ScreenUpdating = False 
'  Application.EnableEvents = False 
    Dim PS2 As Boolean 'sheet Protection Situation 
    Dim i As Integer 
    PS2 = Sheets("Sheet1").ProtectContents 

    If Target.Column = [table1[Group Assignment Marks]].Column Then 
     For i = 1 To ListObjects("Table1").DataBodyRange.Rows.Count 
     If Target.Row <> i + Range("Table1[#Headers]").Row Then 
      If [table1].Cells(i, [table1[Student Name]].Column).Value = [table1].Cells(Target.Row - Range("Table1[#Headers]").Row, [table1[Student Name]].Column).Value Then 
       [table1].Cells(i, [table1[Group Assignment Marks]].Column).Value = Target.Value 

      End If 
     End If 
     Next i 
    End If 

     If PS2 Then Sheets("Sheet1").Unprotect 

' Application.EnableEvents = True 
End If 
End Sub 

Answer 2

此更新组标记

---

将此放在Sheet 1中模块

Option Explicit 

Private Sub Worksheet_Change(ByVal Target As Range) 
    Application.EnableEvents = False 
    With Target 
     If .CountLarge = 1 And .Column = 3 Then 
      If Not IsError(.Value2) Then 
       Dim mark As String, r As Long 
       mark = .Value2 
       r = .Row 
       Application.Undo 
       AssignGroupMark mark, r 
       .Offset(1).Activate 
      End If 
     End If 
    End With 
    Application.EnableEvents = True 
End Sub 

---

放置这在通用的VBA 模块1

Option Explicit 

Public Sub AssignGroupMark(ByVal mark As String, markRow As Long) 
    Dim ws As Worksheet, ur As Variant, ubR As Long, r As Long, d As Object 

    Set ws = Sheet1 
    Set d = CreateObject("Scripting.Dictionary") 

    ur = ws.UsedRange 'Row 1 is headers 
    ubR = UBound(ur, 1) 

    For r = 2 To ubR 
     If Len(ur(r, 2)) Then 
      If r = markRow Then 
       d(ur(r, 2)) = mark 
      Else 
       If Not d.Exists(ur(r, 2)) Then d(ur(r, 2)) = ur(r, 3) 
      End If 
     End If 
    Next 
    For r = 2 To ubR 
     If Len(ur(r, 1)) Then ur(r, 3) = d(ur(r, 2)) 
    Next 
    ws.UsedRange = ur 
End Sub 

---

Sheet 1中：