vba将超大excel文件（含成百上千工作表）在不打开的情况下将工作表复制另存为工作簿

likeyouli · 发表于 2025-9-5 11:43:40

本帖最后由 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:11

占楼备用

wn168cn@163.com · 发表于 2025-9-5 13:35:12

感谢楼主分享

guong · 发表于 2025-9-5 13:36:52

感谢分享！

likeyouli · 发表于 2025-9-5 16:58:35

本帖最后由 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:40

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:35

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]

属性	值	说明
ReadOnly	TRUE/FALSE	是否只读模式
MaxScanRows	数字 (如 16)	扫描行数来确定数据类型
CharacterSet	ANSI/UTF-8	字符编码
ImportMixedTypes	Text/MajorityType	混合类型导入方式

完整语法格式vba

"Extended Properties=""属性1=值1;属性2=值2;属性3=值3"""

常用组合示例示例1：基本读取（推荐）vba

"Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"""

Excel 2007+格式，有列标题，混合类型作为文本

示例2：读取旧格式文件vba

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

"Extended Properties=""Excel 12.0;HDR=NO"""
示例4：高级配置vba

"Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;MaxScanRows=20;ReadOnly=TRUE"""

在VBA中的实际使用标准写法：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"";"
使用变量：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 的重要性vba

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

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

' 对于.xls文件"Extended Properties=""Excel 8.0;HDR=YES;IMEX=1"""' 对于.xlsx文件 "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"""

完整示例代码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	根据文件格式选择
HDR	YES	如果第一行是列标题
IMEX	1	非常重要，避免数据丢失
其他	按需添加	如ReadOnly、MaxScanRows等

最常用的组合："Excel 12.0;HDR=YES;IMEX=1"

这些属性可以确保数据导入的准确性和稳定性，特别是IMEX=1对于处理混合数据类型的列非常重要。

寂寞人生 · 发表于 2025-12-27 21:43:18

感谢分享！

xinjie321 · 发表于 5 天前

感谢大佬无私分享！

kao_rpg · 发表于 5 天前

感谢分享

		自动登录	找回密码
密码			注册