求用代码筛选数据并复制到新的文档

44971717

公司有一批数据，要求根据名字划分数据到个人并制成表格，具体信息见附件，表格里面的人员不固定，数据量很大，接近100万条。

shiruiqiang

直接wps里有拆分表的功能

cjc209

工作表拆分 代码多的是

gwjkkkkk

请参考。。。

cjc209

function 拆分工作表成多薄一表(){
        var arr=Intersect(Range("a2").CurrentRegion,Range("a2").CurrentRegion.Offset(1)).Value();
        var m=new Map(),pah=ThisWorkbook.Path+"\\";
        var titarr=Range("a1").Resize(1,arr[0].length).Value().flat();
       
        for (var ar of arr){
                if (m.has(ar[3])){
                        var newarr=m.get(ar[3]).concat([ar]);
                        m.set(ar[3],newarr);
                }else{
                        m.set(ar[3],[titarr,ar])
                }
        }//ar[3]以姓名列拆分
       
        for (var [key,val] of m){
                var wb=Workbooks.Add();
                var ws=wb.Sheets.Add();
                ws.Name=key;
                ws.Range("a1").Resize(val.length,val[0].length).Value2=val;
                wb.SaveAs(pah+key+".xlsx");wb.Close();
        }
       
}

44971717

gwjkkkkk 发表于 2023-3-8 19:32
请参考。。。

非常感谢帮助，数据少的时候完美运行，可是我的数据过大，有80多万条。运行脚本的时候提示内存溢出.........这个有点头疼

fzxba

1. Sub test0() '慢慢等，不会慢
   
2.   Dim Conn As Object, rs As Object, p As String, f As String, s As String
   
3.   p = ThisWorkbook.Path & "\分簿"
   
4.   If Dir(p, vbDirectory) = "" Then MkDir p
   
5.   Set Conn = CreateObject("ADODB.Connection")
   
6.   Set rs = CreateObject("ADODB.Recordset")
   
7.   Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 XML;Data Source=" & ThisWorkbook.FullName
   
8.   s = "SELECT DISTINCT 名字 FROM [" & ActiveSheet.Name & "$] WHERE LEN(名字)"
   
9.   rs.Open s, Conn, 1, 3
   
10.   While Not rs.EOF
    
11.     s = rs.Fields(0).Value
    
12.     f = p & Application.PathSeparator & s & ".xlsx"
    
13.     If Dir(f) <> "" Then Kill f
    
14.     Conn.Execute "SELECT * INTO [" & f & "].[Sheet1] FROM [" & ActiveSheet.Name & "$] WHERE 名字='" & s & "'"
    
15.     rs.MoveNext
    
16.   Wend
    
17.   rs.Close
    
18.   Set rs = Nothing
    
19.   Conn.Close
    
20.   Set Conn = Nothing
    
21.   Beep
    
22. End Sub

复制代码

fzxba

参与_审核见附件_仅供测试.rar (46.74 KB, 下载次数: 17)

2023-3-8 20:09 上传

点击文件名下载附件

lushang2018

lizhipei78

单纯的拆分还是用WPS自带的吧，快速且保留原格式，以上大神的都不会保留原格式，如字体呀，列宽啊，粗体等