初学者求助，数据分类方面

SMART晓

本人半道初学VBA，包括子程序调用，循环递减，字典法，很多都不知道怎么用，请大神帮我看看这个应该怎么写，我自己写了2个小的子程序，应该说改了2个，是在论坛内找到然后修改的。请大神帮忙撸一份代码我学习一下。有偿学习，感谢！
要求：1依照D列的名单（数字不定，可能是3个4个5个10个）
          3，以张三李四等为工作表名称新建表格
          2，平均分数据，例如现在为282/4=70个，多余的不足放在最后一张表
          4，每张表格B列相同内容超过4个，标注在对应的表格内，标红

SMART晓

Sub 计数()
k = 1
LastRow = ActiveSheet.UsedRange.Rows.Count
LastColumn = ActiveSheet.UsedRange.Columns.Count
Set dic = CreateObject("scripting.dictionary")
For I = 1 To Sheets("sheet1").Cells(2, 4).End(xlDown).Row
    J = 2
        If ActiveSheet.Cells(I, J) <> "" Then
            s = ActiveSheet.Cells(I, J).Value
            If Not dic.exists(s) Then
                dic(s) = 1
            Else
                dic(s) = dic(s) + 1
            End If
        End If
Next
For Each xm In dic.keys
    If dic(xm) >= 4 Then
        ActiveSheet.Cells(k, 6) = xm
        ActiveSheet.Cells(k, 7) = dic(xm)
        k = k + 1
    End If
Next
Set dic = Nothing
End Sub

SMART晓

写了2个小程序，一个是把相同内容超过4个的列出来，一个是循环新建表格的，还有一些功能不明白如何实现，也不会子程序调用，请大神指点

SMART晓

朱荣兴 发表于 2018-8-27 23:26
似乎是个拆分问题，但究竟是要根据什么来拆分不明白

是啊，之前有高手告诉我说可以用循环递减的方法，用总数减去每个分表的数量，最后一个表包含所有数据可以做，可是我不会。我是用counta计算，然后提取相应的行数做的，这样的话没办法取余数，而且到了循环新建表格的时候容易出问题，子程序调用我还不是很熟练啊

SMART晓

早晨顶一发，有大神看到嘛

魂断蓝桥

4，每张表格B列相同内容超过4个，标注在对应的表格内，标红

这个没看懂，张三表格中

1        6
7        5

这几个数据是什么意思？

魂断蓝桥

Sub A()
Dim cnn, rs As Object, Sql As String, sh As Worksheet, arr, i%, M
Set cnn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.Recordset")
arr = Sheet1.Range("d2:d" & Sheet1.[d99].End(3).Row)
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Name <> "Sheet1" Then sh.Delete
Next
Application.DisplayAlerts = True
M = (Sheet1.[a999].End(3).Row - 1) \ UBound(arr)
cnn.Open "Provider=Microsoft.ACE.OleDb.12.0;Extended Properties='Excel 12.0;HDR=NO'; Data Source=" & ThisWorkbook.FullName
Sql = "select * from [sheet1$A2:C" & [A9999].End(3).Row & "]"
rs.Open Sql, cnn, 1, 1
For i = 1 To UBound(arr)
    Sheets.Add after:=Sheets(Sheets.Count)
        With ActiveSheet
            .Name = arr(i, 1)
            .[b1] = arr(i, 1)
            If i = UBound(arr) Then
                 .[a2].CopyFromRecordset rs
            Else
                  .[a2].CopyFromRecordset rs, M
            End If
            .Columns("a:c").EntireColumn.AutoFit
        End With
Next
Set rs = Nothing
Set cnn = Nothing
End Sub

金和苑2

这个没看懂你的要求

SMART晓

魂断蓝桥 发表于 2018-8-28 08:31
4，每张表格B列相同内容超过4个，标注在对应的表格内，标红

这个没看懂，张三表格中

其实前面的1和7原本是学生的电话号码，为了保护学生隐私我匿了一下，感谢大神