无忧启动论坛

标题: vba将超大excel文件（含成百上千工作表）在不打开的情况下将工作表复制另存为工作簿 [打印本页]
作者: likeyouli    时间: 2025-9-5 11:43
标题: vba将超大excel文件（含成百上千工作表）在不打开的情况下将工作表复制另存为工作簿
本帖最后由 likeyouli 于 2025-9-5 16:06 编辑

一个工作簿（xlsx，xls，含很多工作表），超过200Mb就比较难打开了，超过500M甚至上GB的，就只能往而兴叹了 。
在不打开工作簿的情况下，将里边的工作表复制出来，每个工作表另存为一个工作簿：

Sub 大excel文件不打开将工作表拆分出来()
Dim filepath As String, weizhi As String, chaifen As Workbook, linshi As Worksheet, n as Integer
'让用户选择源文件
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "请选择要拆分的超大XLSX文件"
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls"
        If .Show = -1 Then
            filepath = .SelectedItems(1)
        Else
            MsgBox "未选择文件。操作已取消。"
            Exit Sub
        End If
    End With
weizhi = Left(filepath, InStrRev(filepath, "\"))
Set linshi = ActiveWorkbook.Worksheets.Add
For n = 1 To 3
DoEvents
TableName = GetSheetNameByADO(filepath, n)
If TableName = "" Then Exit For

Application.CutCopyMode = False '取消任何当前的复制或剪切操作状态，避免影响后续操作
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array( _
    "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Password="""";User ID=Admin;Data Source=" & filepath & ";Mode=Share Deny Write;  Extended Proper", "ties=""HDR=YES;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine Type=37;" _
        , _
        "Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Databas" _
        , _
        "e Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=Fal" _
        , _
        "se;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False;Jet OLEDB:Support Complex Data=False;Jet OLEDB:Bypass User" _
        , _
        "Info Validation=False;Jet OLEDB:Limited DB Caching=False;Jet OLEDB:Bypass ChoiceField Validation=False" _
        ), Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdTable
        .CommandText = Array("" & TableName & "$")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .SourceDataFile = filepath
        .ListObject.DisplayName = "表5_xianyiyuan" & n
        .Refresh BackgroundQuery:=False
    End With
    DoEvents
    Range("表5_xianyiyuan" & n & "[#All]").Select
    Selection.Copy
    Set chaifen = Workbooks.Add
  '  Sheets.Add After:=ActiveSheet
    chaifen.Worksheets(1).Range("a1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
     chaifen.SaveAs weizhi & TableName
     chaifen.Close False
     Application.DisplayAlerts = False  ' 禁用警告
ActiveSheet.Delete
Application.DisplayAlerts = True
     Set linshi = ActiveWorkbook.Worksheets.Add
Next n
MsgBox "大excel文件的工作表拆分完毕"
End Sub

Function GetSheetNameByADO(filepath As String, sheetIndex As Integer) As String
    On Error GoTo ErrorHandler
    Dim conn As Object, rs As Object, i As Integer
    Set conn = CreateObject("ADODB.Connection")
    If LCase(Right(filepath, 4)) = ".xls" Then
        conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & filepath & ";Extended Properties='Excel 8.0;HDR=NO';"
    Else
        conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & filepath & ";Extended Properties='Excel 12.0 Xml;HDR=NO';"
    End If
    Set rs = conn.OpenSchema(20) '20 = adSchemaTables
    i = 0
    Do While Not rs.EOF
        If InStr(rs.Fields("TABLE_NAME").Value, "$") > 0 And _
           Left(rs.Fields("TABLE_NAME").Value, 4) <> "MSys" Then
            i = i + 1
            If i = sheetIndex Then
                GetSheetNameByADO = Replace(rs.Fields("TABLE_NAME").Value, "$", "")
                Exit Do
            End If
        End If
        rs.MoveNext
    Loop
    rs.Close
    conn.Close
    Exit Function
ErrorHandler:
    GetSheetNameByADO = ""
    On Error Resume Next
    If Not rs Is Nothing Then rs.Close
    If Not conn Is Nothing Then conn.Close
End Function




作者: likeyouli    时间: 2025-9-5 12:16
占楼备用
作者: likeyouli    时间: 2025-9-5 12:16
占楼备用11
作者: wn168cn@163.com    时间: 2025-9-5 13:35
感谢楼主分享
作者: guong    时间: 2025-9-5 13:36

感谢分享！
作者: likeyouli    时间: 2025-9-5 16:58
本帖最后由 likeyouli 于 2025-9-9 08:16 编辑

Sub 大excel文件不打开将工作表拆分出来()
Dim filepath As String, weizhi As String, chaifen As Workbook, linshi As Worksheet, n As Long
'让用户选择源文件
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "请选择要拆分的超大XLSX文件"
        .Filters.Clear
        .AllowMultiSelect = True  ' true时可选择多个文件需要For i = 1 To .SelectedItems.Count循环filepath = .SelectedItems(i)
        .Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls"
        If .Show = -1 Then
            filepath = .SelectedItems(1)
        Else
            MsgBox "未选择文件。操作已取消。"
            Exit Sub
        End If
    End With
weizhi = Left(filepath, InStrRev(filepath, "\"))
Set linshi = ActiveWorkbook.Worksheets.Add
For n = 1 To 5
DoEvents
TableName = GetSheetNameByADO(filepath, n)
If TableName = "" Then Exit For

Application.CutCopyMode = False
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array("OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin; Data Source=" & filepath & _
      "  ;Mode=Share Deny Write;  Extended Properties=""Excel 12.0;HDR=NO;IMEX=1"";Jet OLEDB:Engine Type=37;Jet OLEDB:New Database Passw" _
    , "ord="""";Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False"), Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdTable
        .CommandText = Array("" & TableName & "$")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .SourceDataFile = filepath
        .ListObject.DisplayName = "表5_xianyiyuan" & n
        .Refresh BackgroundQuery:=False
    End With
    DoEvents
    Range("表5_xianyiyuan" & n & "[#All]").Select
    Selection.Copy
    Set chaifen = Workbooks.Add
  '  Sheets.Add After:=ActiveSheet
    chaifen.Worksheets(1).Range("a1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
    chaifen.Worksheets(1).Range("a1").EntireRow.Delete
     chaifen.SaveAs weizhi & TableName
     chaifen.Close False
       Application.DisplayAlerts = False  ' 禁用警告
        ActiveSheet.Delete
        Application.DisplayAlerts = True
     Set linshi = ActiveWorkbook.Worksheets.Add
Next n
MsgBox "大excel文件的工作表拆分完毕"
End Sub

Function GetSheetNameByADO(filepath As String, sheetIndex As Long) As String
    On Error GoTo ErrorHandler
    Dim conn As Object, rs As Object, i As Integer
    Set conn = CreateObject("ADODB.Connection")
    If LCase(Right(filepath, 4)) = ".xls" Then
        conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & filepath & ";Extended Properties='Excel 8.0;HDR=NO';"
    Else
        conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & filepath & ";Extended Properties='Excel 12.0 Xml;HDR=NO';"
    End If
    Set rs = conn.OpenSchema(20) '20 = adSchemaTables
    i = 0
    Do While Not rs.EOF
        If InStr(rs.Fields("TABLE_NAME").Value, "$") > 0 And _
           Left(rs.Fields("TABLE_NAME").Value, 4) <> "MSys" Then
            i = i + 1
            If i = sheetIndex Then
                GetSheetNameByADO = Replace(rs.Fields("TABLE_NAME").Value, "$", "")
                Exit Do
            End If
        End If
        rs.MoveNext
    Loop
    rs.Close
    conn.Close
    Exit Function
ErrorHandler:
    GetSheetNameByADO = ""
    On Error Resume Next
    If Not rs Is Nothing Then rs.Close
    If Not conn Is Nothing Then conn.Close
End Function



作者: likeyouli    时间: 2025-9-9 08:14
Application.CutCopyMode = False
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array("OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin; Data Source=" & filepath & _
      "  ;Mode=Share Deny Write;  Extended Proper", "ties=""HDR=YES;"";Jet OLEDB:Engine Type=37;Jet OLEDB:New Database Passw" _
    , "ord="""";Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False"), Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdTable
        .CommandText = Array("" & TableName & "$")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .SourceDataFile = filepath
        .ListObject.DisplayName = "表5_xianyiyuan" & n
        .Refresh BackgroundQuery:=False
    End With
详解这段代码
好的，我来详细解析这段代码。这是一个非常典型的使用ADO连接将外部Excel数据导入到当前工作表的代码。

代码功能概述
这段代码的功能是：通过OLEDB连接，将外部Excel文件的指定工作表数据导入到当前活动工作表中，并创建为一个表格对象（ListObject）。

逐部分详解
1. 清除剪贴板状态
vba
Application.CutCopyMode = False
作用：取消任何当前的复制或剪切操作状态，避免影响后续操作

2. 创建ListObject并建立连接
vba
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array("OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin; Data Source=" & filepath & _
      "  ;Mode=Share Deny Write;  Extended Proper", "ties=""HDR=YES;"";Jet OLEDB:Engine Type=37;Jet OLEDB:New Database Passw" _
    , "ord="""";Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False"), Destination:=Range("$A$1")).QueryTable
ActiveSheet.ListObjects.Add：在当前活动工作表创建表格对象

SourceType:=0：表示数据源类型为xlSrcExternal（外部数据源）

Source:=Array(...)：连接字符串被分成数组形式（因为VBA字符串长度限制）

Destination:=Range("$A$1")：数据导入到A1单元格开始的位置

3. 连接字符串解析
连接字符串被分成三部分（因为VBA的字符串长度限制）：

vba
"OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin; Data Source=" & filepath & "  ;Mode=Share Deny Write;  Extended Proper"
"ties=""HDR=YES;"";Jet OLEDB:Engine Type=37;Jet OLEDB:New Database Passw"
"ord="""";Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False"
合并后的完整连接字符串：

text
OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;
Data Source=文件路径;
Mode=Share Deny Write;  
Extended Properties="HDR=YES;";
Jet OLEDB:Engine Type=37;
Jet OLEDB:New Database Password="";
Jet OLEDB:Don't Copy Locale on Compact=False;
Jet OLEDB:Compact Without Replica Repair=False
关键参数说明：

Provider=Microsoft.ACE.OLEDB.12.0：使用ACE OLEDB提供程序

Data Source=文件路径：指定要连接的Excel文件

HDR=YES：第一行包含列标题

Mode=Share Deny Write：以共享方式打开，拒绝写入

4. 查询表属性设置
vba
.CommandType = xlCmdTable
.CommandText = Array("" & TableName & "$")
CommandType = xlCmdTable：命令类型为表命令

CommandText：指定要导入的工作表名称（格式：工作表名$）

5. 刷新和行为设置
vba
.RowNumbers = False                    ' 不显示行号
.FillAdjacentFormulas = False          ' 不填充相邻公式
.PreserveFormatting = True             ' 保留源格式
.RefreshOnFileOpen = False             ' 打开文件时不自动刷新
.BackgroundQuery = True                ' 后台查询
.RefreshStyle = xlInsertDeleteCells    ' 刷新时插入删除单元格
.SavePassword = False                  ' 不保存密码
.SaveData = True                       ' 保存数据
.AdjustColumnWidth = True              ' 自动调整列宽
.RefreshPeriod = 0                     ' 不自动定期刷新
.PreserveColumnInfo = True             ' 保留列信息
.SourceDataFile = filepath             ' 设置源数据文件
6. 表格命名和立即刷新
vba
.ListObject.DisplayName = "表5_xianyiyuan" & n
.Refresh BackgroundQuery:=False
DisplayName：设置表格的显示名称（包含变量n）

Refresh BackgroundQuery:=False：立即刷新数据（不采用后台查询）

7. 结束With块
vba
End With
代码的等效操作
这段代码相当于手动操作：

数据 → 获取数据 → 从文件 → 从Excel工作簿

选择文件和具体工作表

将数据加载到Excel表格中

可能的问题和改进建议
潜在问题：
字符串分割：连接字符串被硬性分割可能容易出错

表格名称：硬编码的"表5_xianyiyuan"可能冲突

错误处理：缺少错误处理，如果文件不存在会崩溃

改进建议：
vba
' 使用完整的连接字符串（避免分割）
Dim connStr As String
connStr = "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;" & _
          "Data Source=" & filepath & ";" & _
          "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"";"

' 添加错误处理
On Error GoTo ErrorHandler

With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=connStr, Destination:=Range("$A$1")).QueryTable
    ' ... 其他设置
    .Refresh BackgroundQuery:=False
End With
总结
这段代码是通过编程方式创建外部数据连接，将另一个Excel文件的数据导入到当前工作表，并转换为智能表格。这种方法的好处是：

不打开源文件：避免内存占用

创建动态连接：数据可以刷新更新

自动化处理：无需手动操作导入数据

这是一种高级的Excel数据自动化处理技术！

作者: likeyouli    时间: 2025-9-9 08:27
Extended Properties都有哪些属性？ 能否详细说一下好的！Extended Properties 是OLEDB连接字符串中非常重要的部分，特别是用于Excel连接时。以下是详细的属性说明：
Extended Properties 常用属性1. HDR (Header)
  • 用途：指定第一行是否包含列标题
  • 值：

    • HDR=YES：第一行是列标题（默认）
    • HDR=NO：第一行是数据，自动生成F1、F2...作为列名


2. IMEX (Import Export Mode)
  • 用途：处理混合数据类型的列
  • 值：

    • IMEX=0：导出模式（默认）
    • IMEX=1：导入模式（将混合类型列作为文本处理）
    • IMEX=2：链接模式（完全只读）


IMEX=1 是最常用的，可以避免数字和文本混合列的数据丢失。
3. Excel 版本标识
  • 用途：指定Excel文件格式版本
  • 值：

    • Excel 8.0：Excel 97-2003 (.xls)
    • Excel 12.0：Excel 2007+ (.xlsx, .xlsb)
    • Excel 12.0 Xml：Excel 2007+ XML格式
    • Excel 12.0 Macro：启用宏的工作簿 (.xlsm)


4. 其他常用属性


[td]
属性
值
说明
ReadOnlyTRUE/FALSE是否只读模式
MaxScanRows数字 (如 16)扫描行数来确定数据类型
CharacterSetANSI/UTF-8字符编码
ImportMixedTypesText/MajorityType混合类型导入方式

完整语法格式[size=12.573px]vba



"Extended Properties=""属性1=值1;属性2=值2;属性3=值3"""
常用组合示例示例1：基本读取（推荐）[size=12.573px]vba



"Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"""
示例2：读取旧格式文件[size=12.573px]vba



"Extended Properties=""Excel 8.0;HDR=YES;IMEX=1"""
示例3：无列标题的文件[size=12.573px]vba



"Extended Properties=""Excel 12.0;HDR=NO"""
示例4：高级配置[size=12.573px]vba



"Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;MaxScanRows=20;ReadOnly=TRUE"""
在VBA中的实际使用标准写法：[size=12.573px]vba



Dim connStr As StringconnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _          "Data Source=C:\file.xlsx;" & _          "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"";"
使用变量：[size=12.573px]vba



Dim filePath As StringfilePath = "C:\data.xlsx"Dim extendedProps As StringextendedProps = "Excel 12.0;HDR=YES;IMEX=1"Dim connStr As StringconnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _          "Data Source=" & filePath & ";" & _          "Extended Properties=""" & extendedProps & """;"
特殊注意事项1. IMEX=1 的重要性[size=12.573px]vba



' 没有IMEX=1：可能导致数据丢失"Extended Properties=""Excel 12.0;HDR=YES"""' 有IMEX=1：保持数据完整性  "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"""
2. 引号转义规则[size=12.573px]vba



' 正确：使用两个双引号表示一个实际双引号"Extended Properties=""Excel 12.0;HDR=YES"""' 错误：直接使用一个双引号"Extended Properties="Excel 12.0;HDR=YES""
3. 文件格式匹配[size=12.573px]vba



' 对于.xls文件"Extended Properties=""Excel 8.0;HDR=YES;IMEX=1"""' 对于.xlsx文件  "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"""
完整示例代码[size=12.573px]vba



Sub ImportExcelData()    Dim filePath As String    filePath = "C:\Data\sales.xlsx"        Dim connStr As String    connStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _              "Data Source=" & filePath & ";" & _              "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;ReadOnly=TRUE"";"        With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=connStr, Destination:=Range("$A$1")).QueryTable        .CommandType = xlCmdTable        .CommandText = "Sheet1$"        .Refresh BackgroundQuery:=False    End WithEnd Sub
总结


[td]
属性
推荐值
说明
Excel版本Excel 12.0 或 Excel 8.0根据文件格式选择
HDRYES如果第一行是列标题
IMEX1非常重要，避免数据丢失
其他按需添加如ReadOnly、MaxScanRows等

最常用的组合："Excel 12.0;HDR=YES;IMEX=1"
这些属性可以确保数据导入的准确性和稳定性，特别是IMEX=1对于处理混合数据类型的列非常重要。









欢迎光临 无忧启动论坛 (http://bbs.c3.wuyou.net/) Powered by Discuz! X3.3