1.  人员分类（数组） by:山菊花

‘山菊花_VBA(数组)人员分类.xls
Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False '运行下面程序时，不进行屏幕刷新
    Dim nR_a%, nR_b%, cBy$ '声明变量
    Dim s1%, s2%, s3%, Arr1(), Arr3()
    nR_a = Range("a65536").End(xlUp).Row 'A列最后一行的行号
    Sy = WorksheetFunction.Transpose(Range("a3:a" & nR_a)) '上月名单保存到数组
    nR_b = Range("b65536").End(xlUp).Row 'B列最后一行的行号
    By = WorksheetFunction.Transpose(Range("b3:b" & nR_b)) '本月名单保存到数组
    Range("c3:f" & nR_a + nR_b + 2).ClearContents '清除C至F列原来结果
    cBy = Join(By, ",") '把本月名单转换到单值变量cBy中
    s = UBound(Sy) '上月人数
    s1 = 0: s2 = 0: s3 = 0 '给变量赋初值
    For i = 1 To s '循环上月名单
        If InStr(cBy, Sy(i) & ",") > 0 Or Right(cBy, Len(Sy(i))) = Sy(i) Then '如果在本月名单中找到上月名单中的名字(留守人员)
            If Right(cBy, Len(Sy(i))) = Sy(i) Then
                cBy = Left(cBy, Len(cBy) - Len(Sy(i)))  '在cby中删除找到的名字
            Else
                cBy = Replace(cBy, Sy(i) & ",", "")
            End If
            s1 = s1 + 1
            ReDim Preserve Arr1(1 To s1) '重新定义动态数组Arr1
            Arr1(s1) = Sy(i)  '把该名字保存到数组Arr1中
        Else
            s3 = s3 + 1
            ReDim Preserve Arr3(1 To s3)
            Arr3(s3) = Sy(i) '如果在本月名单中找不到上月中的名字，把该名字保存到数组Arr3中(离开人员)。
        End If
    Next
   
   
    Arr2 = Split(cBy, ",") '把cby剩余的名字保存到数组Arr2中(新增人员)
   
    s2 = UBound(Arr2) + 1
    With WorksheetFunction
        Range("d3").Resize(s1) = .Transpose(Arr1) '把数组的值输出到工作中
        Range("e3").Resize(s2) = .Transpose(Arr2)
        Range("f3").Resize(s3) = .Transpose(Arr3)
    End With
   
   
    '把各数组元素添加人员性质“留守、新增、离开”，再输出到工作表C列：
   
    s = IIf(s1 > s2, s1, s2)
    s = IIf(s > s3, s, s3)
    For i = 1 To s
        If i <= s1 Then Arr1(i) = Arr1(i) & "留守"
        If i <= s2 Then Arr2(i - 1) = Arr2(i - 1) & "新增"
        If i <= s3 Then Arr3(i) = Arr3(i) & "离开"
    Next
   
    With WorksheetFunction
        Range("c3").Resize(s1) = .Transpose(Arr1)
        Range("c" & 3 + s1).Resize(s2) = .Transpose(Arr2)
        Range("c" & 3 + s1 + s2).Resize(s3) = .Transpose(Arr3)
    End With
   
    Application.ScreenUpdating = True '打开屏幕刷新
End Sub