求大神指导下，拆分工作表

sunhui008

拆分文件

拆分学校基本信息表，以学校J列为基准，相同学校的为一个表，进行分表操作。
保留首行，但是分表后要删除学校列，工作表命名为“学生基本信息”，并在此表前新建表命名“模板说明”
拆分表的文件保存在此文件所在的文件夹目录，文件按照学校名字进行命名。

拆分文件.rar (392.87 KB, 下载次数: 18)

2023-6-6 11:30 上传

点击文件名下载附件

liulang0808

Sub test()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("学生基本信息").UsedRange
    Application.ScreenUpdating = False
    Sheets("学生基本信息").Select
    For j = 2 To UBound(arr)
        If Len(arr(j, 10)) > 0 Then
            If d.exists(arr(j, 10)) Then
                Set d(arr(j, 10)) = Union(d(arr(j, 10)), Cells(j, 1))
            Else
                Set d(arr(j, 10)) = Union([a1], Cells(j, 1))
            End If
        End If
    Next j
    Sheets("学生基本信息").Copy
    With ActiveWorkbook
        .Sheets.Add before:=.Sheets(1)
        .Sheets(1).Name = "模板说明"
        For Each k In d.keys
            .Sheets(2).UsedRange.Clear
            d(k).EntireRow.Copy .Sheets(2).[a1]
            .Sheets(2).Columns(10).Delete
            .SaveAs ThisWorkbook.Path & "\" & k & ".xlsx"
        Next
        .Close False
    End With
    Application.ScreenUpdating = True
End Sub

liulang0808

附件内容供参考。。。。。

sunhui008

liulang0808 发表于 2023-6-6 12:14
附件内容供参考。。。。。

太狠了 短短几行代码  解决问题

ykcbf1100

用字典做一个。

ykcbf1100

附件供参考。。。

sunhui008

ykcbf1100 发表于 2023-6-6 14:35
附件供参考。。。

谢谢

sunhui008

还有个问题
下面的代码如何优化呀 分别判断A列   B列是否存在重复值，重复值填充蓝色  代码跑几千行数据时候太卡了




    Dim cell As Range                                                                         '“身份证号A列”范围内的重复值并将它们标记为蓝色
    For Each cell In Range("A2:A" & Cells(Rows.Count, 2).End(xlUp).Row)
        If WorksheetFunction.CountIf(cell.Parent.Columns(1), cell.Value & "*") > 1 Then
            cell.Interior.color = RGB(0, 0, 255)
        End If
    Next cell

    Dim shenfenzheng As Range                                                                   '“身份证号A列”空白行背景色
    For Each shenfenzheng In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        If Len(shenfenzheng.Value) = 0 Then
            shenfenzheng.Interior.ColorIndex = xlNone
        End If
    Next shenfenzheng


  For Each cell In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)                           '”学籍号B列”范围内的重复值并将它们标记为蓝
        If WorksheetFunction.CountIf(cell.Parent.Columns(2), cell.Value & "*") > 1 Then
            cell.Interior.color = RGB(0, 0, 255)
        End If
    Next cell

    Dim xuejihao As Range                                                                       '清楚B列学籍号空白行背景色
    For Each xuejihao In Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)
        If Len(xuejihao.Value) = 0 Then
            xuejihao.Interior.ColorIndex = xlNone
        End If
    Next xuejihao

熊文来

也是一个按模板要求生成工作簿的文件，非常好！

熊文来

ykcbf1100 发表于 2023-6-6 14:35
附件供参考。。。

必须留个脚印！