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中：