如何把一个工作薄中多个工作表里通过关键字拆分到新的工作簿中

enshen1121

如何把一个工作薄中多个工作表里通过关键字拆分到新的工作簿中

liulang0808

看看是不是雷同的需求，供参考。。。。。

wxxydl

举例  说清楚

enshen1121

wxxydl 发表于 2021-10-18 21:08
举例  说清楚

模板3 当中有20几个工作表，每个工作表当中都有“营销部”一列，按照“营销部”这一列当中的关键字，办20多个工作表 分成工作簿，每个工作簿的名字已关键字命名。

liulang0808

enshen1121 发表于 2021-10-18 21:12
模板3 当中有20几个工作表，每个工作表当中都有“营销部”一列，按照“营销部”这一列当中的关键字，办20 ...

运营商干活都这么费劲了吗？
看二楼的案例

enshen1121

liulang0808 发表于 2021-10-18 21:08
看看是不是雷同的需求，供参考。。。。。

可以使用，但是数据太大了有点卡！！

3190496160

一薄多表拆分为多薄一表，到我的主题里面去找找吧，几个拆分工具一定有一个适合你的，下载就能用

zpy2

enshen1121 发表于 2021-10-18 21:43
可以使用，但是数据太大了有点卡！！

卡这个问题感觉比较难解决。。。。换电脑？

chxw68

看了一下楼主的数据，很多表格都是五六万行数据，这个想快很难，毕竟数据量在那放着呢。

enshen1121

chxw68 发表于 2021-10-19 10:00
看了一下楼主的数据，很多表格都是五六万行数据，这个想快很难，毕竟数据量在那放着呢。

Sub Opiona()
    Rem 禁止系统刷屏?触发其他事件等
    'On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
    Application.ScreenUpdating = False '//关闭屏幕刷新
    Application.DisplayAlerts = False '//关闭系统提示
    Application.EnableEvents = False  '//禁止触发其他事件
    Application.StatusBar = True   '关闭系统状态条
    Dim T
    T = Timer   '//开始时间
    Dim Str_coon, StrSQL As String
    Dim SQLARR, ARX
    Dim FileArr, WB, FSO
    Dim DATETEMP, DATE开始, DATE结束 As String
    Dim PathG As String
    Dim I, X, ICINT As Long
    Dim SHX, SHW As Worksheet
   
   
    Rem 准备结果文件夹
    PathG = ThisWorkbook.Path & "\拆分表"
   
   
    Set SHX = Worksheets("汇总表")
    Str_coon = "HDR=yes';Data Source =" & ThisWorkbook.FullName     '//OFFICE2003，2007 通用
   
    Rem  先获取要拆分字段的不重复值
    StrSQL = "SELECT DISTINCT [字段2]"
    StrSQL = StrSQL & " FROM [" & SHX.Name & "$]"
    StrSQL = StrSQL & " WHERE NOT [字段2] IS NULL AND LEN([字段2])>0"
    ARX = GET_SQL_To_Arr(StrSQL, Str_coon, False)  '//不重复姓名放入二维数组
   
    If ARX(0, 0) <> "" And ARX(0, 0) <> "Error" Then
        ICINT = UBound(ARX) + 1
        
        For X = 0 To ICINT - 1 '//循环每一个值
            Rem  提示信息，在状态栏显示
            Application.StatusBar = "需拆分总数：" & ICINT & " 个，当前是第：" & X + 1 & " 个，当前是：" & ARX(X, 0)
            DoEvents
            
            Rem 查询对应数据
            StrSQL = ""
            StrSQL = StrSQL & "SELECT * FROM [" & SHX.Name & "$]"
            StrSQL = StrSQL & " WHERE [字段2]='" & ARX(X, 0) & "'"
            SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, False)
            
            If UBound(SQLARR, 1) > 0 Then  '//没有数据，在不保存
                Rem 新建，粘贴数据，保存文件
                Set WB = Workbooks.Open(PathG & "\" & ARX(X, 0) & ".XLSX")
                Set SHW = WB.Worksheets("Sheet1")
                SHW.Range("A2:IT1048576").ClearContents
                SHW.Range("A2").Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR
                WB.Close True
            End If
        Next
    Else
        MsgBox "未发现拆分依据 需要的值！", vbInformation, "北极狐提示!!"
    End If
   
    Application.StatusBar = False   '恢复系统状态条
    Application.EnableEvents = True  '//  '//恢复触发其他事件
    Application.ScreenUpdating = True '//恢复屏幕刷新
    Application.DisplayAlerts = True '//恢复系统提示
    MsgBox "一共用时：" & Format(Timer - T, "#0.0000") & " 秒", , "北极狐提示!!"  '//提示所用时间
End Sub

'*****************************************************************************************
'函数名：    GET_SQL_To_Arr
'函数功能：  获得指定SQL的查询结果，自定义连接字符串，可以连接各种数据库
'返回值：    返回一个二维数组
'参数1：     StrSQL   字符类型   SQL查询语句
'参数2：     Str_coon 字符类型   数据库连接语句
'Str_coon = "Provider=Microsoft.JET.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=yes';Data Source=" & ThisWorkbook.FullName      '//OFFICE2003
'Str_coon = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';Data Source =" & ThisWorkbook.FullName     '//OFFICE2007
'Str_coon = "HDR=yes';Data Source =" & FileArr(i)    '//OFFICE2003，2007 通用
'参数3：     Biaoti   可参数选   是否输出标题，默认带有标题
'使用方法：
'            SQLARR= GET_SQL_To_Arr(StrSQL,Str_coon,true)
'            SQLARR(0,1)  '//数组第一行为标题行，从i=1 开始是数据
'            Sh2.Range("A2").Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR
'整理：北极狐工作室 QQ：14885553
'*****************************************************************************************
Public Function GET_SQL_To_Arr(ByVal StrSQL As String, ByVal Str_coon As String, Optional Biaoti As Boolean = True) As Variant()
    On Error Resume Next    ' 改变错误处理的方式。
    Dim CN, RS
    Dim arr()
    Dim I As Long
    Err.Clear
    Set CN = CreateObject("Adodb.Connection") '//新建一个ADO连接
    Set RS = CreateObject("adodb.recordset")
    Rem Str_coon = "HDR=yes';Data Source=" & ThisWorkbook.FullName
    If InStr(Str_coon, "Provider=") = 0 Then
        If Val(Application.Version * 1) < 12 Then
            Str_coon = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;" & Str_coon
        Else
            Str_coon = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;" & Str_coon
        End If
    End If
    CN.CursorLocation = 3
    CN.Open Str_coon
    RS.Open StrSQL, CN, 1, 3
    Rem 如果不要标题，可以：arr = RS.GetRows，代码比较省，但是速度一般
    Rem SET RS=CN.Execute(StrSQL)
    If RS.RecordCount > 0 Then '//如果找到数据
        If Biaoti = True Then
            ReDim arr(0 To RS.RecordCount, 0 To RS.Fields.Count - 1)
            For A = 0 To RS.Fields.Count - 1  '//导入标题
                arr(0, A) = RS.Fields(A).Name
            Next
            For I = 0 To RS.RecordCount - 1  '//导入数据
                For A = 0 To RS.Fields.Count - 1
                    arr(I + 1, A) = RS.Fields(A).Value
                Next A
                RS.MoveNext
            Next
        Else
            ReDim arr(0 To RS.RecordCount - 1, 0 To RS.Fields.Count - 1)
            For I = 0 To RS.RecordCount - 1  '//导入数据
                For A = 0 To RS.Fields.Count - 1
                    arr(I, A) = RS.Fields(A).Value
                Next A
                RS.MoveNext
            Next
        End If
    Else '//如果没有找到数据
        If Biaoti = True Then
            ReDim arr(0 To 0, 0 To RS.Fields.Count - 1)
            For A = 0 To RS.Fields.Count - 1  '//导入标题
                arr(0, A) = RS.Fields(A).Name
            Next
        Else
            ReDim arr(0, 0)
            arr(0, 0) = ""
        End If
    End If
    If Err.Number <> 0 Then
        MsgBox "Error！" & Err.Description
        ReDim arr(0, 0)
        arr(0, 0) = "Error"
        GET_SQL_To_Arr = arr(0, 0)
    End If
    GET_SQL_To_Arr = arr
    RS.Close
    CN.Close  '//关闭ADO连接
    Set RS = Nothing
    Set CN = Nothing  '//释放内存
End Function

这个能否改成1工作簿多个工作表的形式！！