按姓名自动归集个人资料

@鲸鱼玉

笔者手中有公司的一个物品表，表里面第一列是姓名，第二列是物品，第三列是数量，

由于长年累月的记录，物品表很长且很不直观，例如张三借过8次东西，就有8条记录，占了8行，怎么按姓名自动归集个人资料？也就是一个人只占一行，后面就是全部资料，例如A2的内容是张三的名字，B2的内容是圆珠笔×2、排插×1、乒乓球×3。这个怎么实现呢？

经过研究找到了解决方法，特意来给大家分享一下。新建一个Excel文档，按下组合键“Alt+F8”打开宏窗口，随意输入一个宏名，点击“创建”按钮，在打开的VBA窗口中输入如下代码：

Option Explicit

Sub test100()

    Dim Dic, arr1, x, k, y, Dic1, arr3(1 To 100000, 1 To 1)

    Set Dic = CreateObject("Scripting.Dictionary")

    Set Dic1 = CreateObject("Scripting.Dictionary")

    arr1 = Range("A1").CurrentRegion

    ReDim arr2(1 To UBound(arr1), 1 To UBound(arr1, 2))

    For x = 2 To UBound(arr1)

        If Not Dic.exists(arr1(x, 1) & arr1(x, 2)) Then

            k = k + 1

            Dic(arr1(x, 1) & arr1(x, 2)) = k

            arr2(k, 1) = arr1(x, 1)

            arr2(k, 2) = arr1(x, 2)

            arr2(k, 3) = arr1(x, 3)

        Else

            arr2(Dic(arr1(x, 1) & arr1(x, 2)), 3) = arr2(Dic(arr1(x, 1) & arr1(x, 2)), 3) + arr1(x, 3)

        End If

    Next x

    '============================

    For x = 2 To UBound(arr1)

              Dic1(arr1(x, 1)) = ""

    Next x

    For x = 1 To Dic1.Count

        For y = 1 To k

            If arr2(y, 1) = Dic1.keys()(x - 1) Then

                arr3(x, 1) = arr3(x, 1) & arr2(y, 2) & "*" & arr2(y, 3)

            End If

        Next y

    Next x

    Range("E1").CurrentRegion.Clear

    [E1] = "姓名": [F1] = "归集"

    [E2].Resize(Dic1.Count, 1) = Application.Transpose(Dic1.keys)

    [F2].Resize(Dic.Count, 1) = arr3

End Sub

最后，为新增加的宏命令指定一个按钮，今后点击按钮，就自动生成一张归集后的新表格。

董师傅点评：要使用宏功能，需要在“工具”→“宏” →“安全性”中降低安全级别。

教师 

教案只准看不许复制

@别克船长

      才网上下载了一个Word教案,内容很有借鉴价值想复制其中的内容,可发现不能复制粘贴,起初以为是键盘的问题,后面发现就是文档做了限制,后来感觉这个限制技巧很实用，研究了一下就学会了，在此跟大家分享一下：点击菜单栏中的“工具”，选择“保护文档”，在右侧弹出的窗口中勾选第二项“仅允许在文档中进行此类型的编辑”，再点击下拉菜单，选择“填写窗体”，之后点击“是，启动强制保护”，输入一个密码即可，只有知道密码的人才可以删除文档保护复制文档的内容。设置后，当其他人按“Ctrl+A”组合键时，就会发现操作不起作用了 

董师傅点评：如果是高版本的Word,先点击“审阅”，选择“限制编辑”，之后的操作跟上文一样。

怎么办公最有效率？怎么办公最轻松？来看看董师傅的珍藏，相信你一定会有意外的收获。顺带也可以听听董师傅的理财心得，倾听财富的声音！同时有问题也可以微博私信董师傅。