关于按条件带格式拆分数据表的问题

sys911066 · 发表于 2024-4-17 15:25

各位老师，求助查错或重写：
因工作需要，定期需要拆分大师数据表并另存。用AI写了一个，运行时提醒类型不匹配错误。
以下为代码片断：

'For Each cell In columnRange
' If Trim(cell.Value) <> "" Then
' cellValue = Trim(cell.Value)

功能主要要求：

1、根据表格中选定列的内容，进行表格拆分和另存操作，要求保留原有数据格式（如身份证号要保留为文本）。

具体如附件。

非常感谢！

limonet · 发表于 2024-4-17 19:03

关键字：distinct

limonet · 发表于 2024-4-17 19:04

Sub limonet()
Dim S$, Cn As Object, StrSQL$, Arr As Variant, i%, FileFN$
S = Application.InputBox("请选择条件列", , "省份")
Set Cn = CreateObject("Adodb.Connection")
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
Arr = Cn.Execute("Select Distinct " & S & " From [总表$A:G]").GetRows
For i = 0 To UBound(Arr, 2)
      Cn.Close
      FileFN = ThisWorkbook.Path & "\" & Arr(0, i) & ".xlsx"
      StrCn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 XML;Data Source=" & FileFN
      Cn.Open StrCn
      StrSQL = "Select * Into Sheet1 From [Excel 12.0;DataBase=" & ThisWorkbook.FullName & "].[总表$A:G] Where " & S & "='" & Arr(0, i) & "'"
      Cn.Execute (StrSQL)
Next i
End Sub

ykcbf1100 · 发表于 2024-4-17 19:24

附件供参考，2级字典

baofa2 · 发表于 2024-4-17 19:25

本帖最后由 baofa2 于 2024-4-17 19:36 编辑

209901拆分另存模板.zip (38.96 KB, 下载次数: 10)

Option Explicit
Sub test0()
Dim titleRow As Long, splitCol As Long
Dim Conn As Object, rs As Object, SQL As String
Dim strPath As String, strFullName As String, strField As String, strValue As String
titleRow = 1
splitCol = 5
strField = "[" & Cells(1, splitCol).Value & "]"
strPath = ThisWorkbook.Path & "\分簿"
If Dir(strPath, vbDirectory) = "" Then MkDir strPath
Set Conn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 XML;Data Source=" & ThisWorkbook.FullName
SQL = "SELECT DISTINCT " & strField & " FROM [" & ActiveSheet.Name & "$] WHERE LEN(" & strField & ")"
rs.Open SQL, Conn, 1, 3
While Not rs.EOF
strValue = rs.Fields(0).Value
strFullName = strPath & Application.PathSeparator & strValue & ".xlsx"
If Dir(strFullName) <> "" Then Kill strFullName
Conn.Execute "SELECT * INTO [" & strFullName & "].[" & strValue & "] FROM [" & ActiveSheet.Name & "$A:G] WHERE " & strField & "='" & strValue & "'"
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
Conn.Close
Set Conn = Nothing
Beep
End Sub
Sub test1()
Dim ar, Dict As Object, titleRow As Long, splitCol As Long
Dim strPath As String, strKey As String, colSize As Long, i As Long
Application.ScreenUpdating = False
titleRow = 1
splitCol = 5
'splitCol = InputBox("请输入拆分列号", "输入提示：", 3): If Val(splitCol) = 0 Then Exit Sub
'titleRow = InputBox("请输入标题行数", "输入提示：", 6): If Val(titleRow) = 0 Then Exit Sub
strPath = ThisWorkbook.Path & "\分簿"
If Dir(strPath, vbDirectory) = "" Then MkDir strPath
strPath = strPath & "\"
Set Dict = CreateObject("Scripting.Dictionary")
With Worksheets("总表")
ar = .Range("A1").CurrentRegion
colSize = UBound(ar, 2)
For i = titleRow + 1 To UBound(ar)
strKey = Trim(ar(i, splitCol))
If Len(strKey) Then
If Not Dict.Exists(strKey) Then Set Dict(strKey) = .Range("A1").Resize(titleRow, colSize)
Set Dict(strKey) = Union(Dict(strKey), .Cells(i, 1).Resize(, colSize))
End If
Next
End With
Application.DisplayAlerts = False
For i = 0 To Dict.Count - 1
With Workbooks.Add
With .Worksheets(1)
.Name = Dict.Keys()(i)
Dict.Items()(i).Copy .Range("A1")
.DrawingObjects.Delete
.Columns.AutoFit
End With
.SaveAs strPath & Dict.Keys()(i), 51
.Close
End With
Next
Set Dict = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Beep
End Sub
Sub test2() '字典定位数组嵌套
Dim data, temp() As String, results(), Dict As Object, wks As Worksheet
Dim i As Long, j As Long, posRow As Long, strPath As String
Dim titleRow As Long, splitCol As Long
titleRow = 1 '标题所在行
splitCol = 5 '拆分依据列
DoApp False
strPath = ThisWorkbook.Path & Application.PathSeparator & "分簿"
If Dir(strPath, vbDirectory) = "" Then MkDir strPath
strPath = strPath & Application.PathSeparator
' Worksheets("总表").Activate
Set wks = ActiveSheet
Set Dict = CreateObject("Scripting.Dictionary")
data = Range("A1").CurrentRegion
ReDim temp(1 To UBound(data), 1 To UBound(data, 2))
For j = 1 To UBound(data, 2)
For i = 1 To titleRow
temp(i, j) = data(i, j)
Next
Next
For i = titleRow + 1 To UBound(data)
If Not Dict.Exists(data(i, splitCol)) Then Dict(data(i, splitCol)) = Dict.Count + 1
Next
ReDim results(1 To Dict.Count, 1 To 2)
For i = 1 To Dict.Count
results(i, 1) = titleRow
results(i, 2) = temp
Next
For i = titleRow + 1 To UBound(data)
posRow = Dict(data(i, splitCol))
results(posRow, 1) = results(posRow, 1) + 1
For j = 1 To UBound(data, 2)
results(posRow, 2)(results(posRow, 1), j) = data(i, j)
Next
Next
For i = 1 To Dict.Count
wks.Copy
With ActiveWorkbook
With .Worksheets(1)
.Name = results(i, 2)(titleRow + 1, splitCol)
.Range("A1").Resize(results(i, 1), UBound(data, 2)) = results(i, 2)
.DrawingObjects.Delete
.UsedRange.Offset(, UBound(data, 2)).Clear
.UsedRange.Offset(results(i, 1)).Clear
End With
.SaveAs strPath & results(i, 2)(titleRow + 1, splitCol), 51
.Close
End With
Next
Set Dict = Nothing
DoApp
Beep
End Sub
Sub test3()
Dim splitCol As Long, titleRow As Long
titleRow = 1
splitCol = 5
' splitCol = InputBox("请输入拆分列号", "输入提示：", 1): If Val(splitCol) = 0 Then Exit Sub
' titleRow = InputBox("请输入标题行数", "输入提示：", 2): If Val(titleRow) = 0 Then Exit Sub
DoApp False
Dim ar, i As Long, j As Long, rowSize As Long, lastRow As Long
Dim strPath As String, strName As String, wks As Worksheet
strPath = ThisWorkbook.Path & Application.PathSeparator & "分簿"
If Dir(strPath, vbDirectory) = "" Then MkDir strPath
strPath = strPath & Application.PathSeparator
' Worksheets("总表").Activate
Set wks = ActiveSheet
With wks.Range("A1").CurrentRegion
lastRow = .Rows.Count
ar = .Resize(lastRow + 1)
End With
With CreateObject("Excel.Sheet")
With .ActiveSheet.Range("A1").Resize(UBound(ar), UBound(ar, 2))
.Value = ar
With Intersect(.Offset(0), .Offset(titleRow))
.Sort .Item(splitCol), xlDescending, , , , , , xlYes
End With
ar = .Value
End With
.Close
End With
' QuickSort ar, titleRow + 1, lastRow, 1, UBound(ar, 2), splitCol
rowSize = titleRow
For i = titleRow + 1 To lastRow
rowSize = rowSize + 1
For j = 1 To UBound(ar, 2)
ar(rowSize, j) = ar(i, j)
Next
If ar(i, splitCol) <> ar(i + 1, splitCol) Then
strName = ar(i, splitCol)
wks.Copy
With ActiveWorkbook
With .Worksheets(1)
.Range("A1").Resize(rowSize, 3).NumberFormatLocal = "@"
.Range("A1").Resize(rowSize, j - 1) = ar
.UsedRange.Offset(, j - 1).Clear
.UsedRange.Offset(rowSize).Clear
.DrawingObjects.Delete
.Name = strName
End With
.SaveAs strPath & strName, 51
.Close
End With
rowSize = titleRow
End If
Next
Set wks = Nothing
DoApp
Beep
End Sub
Function DoApp(Optional b As Boolean = True)
With Application
.ScreenUpdating = b
.DisplayAlerts = b
.Calculation = -b * 30 - 4135
End With
End Function
Function QuickSort(ar, u As Long, d As Long, l As Long, r As Long, pos As Long)
Dim t As Long, b As Long, x As Long, pivot As String, swap
t = u
b = d
pivot = ar((u + d) \ 2, pos)
While t <= b
Do While t < d
If StrComp(ar(t, pos), pivot, vbTextCompare) = -1 Then t = t + 1 Else Exit Do
Loop
Do While b > u
If StrComp(pivot, ar(b, pos), vbTextCompare) = -1 Then b = b - 1 Else Exit Do
Loop
If t < b Then
For x = l To r
swap = ar(t, x): ar(t, x) = ar(b, x): ar(b, x) = swap
Next
t = t + 1: b = b - 1
Else
If t = b Then t = t + 1: b = b - 1
End If
Wend
If u < b Then QuickSort ar, u, b, l, r, pos
If t < d Then QuickSort ar, t, d, l, r, pos
End Function

复制代码

ykcbf1100 · 发表于 2024-4-17 19:25

参与一下。。。

Sub ykcbf2() '//2024.4.17
Dim wb, arr, sh
Application.ScreenUpdating = False
Application.DisplayAlerts = False
p = ThisWorkbook.Path & ""
Set d = CreateObject("Scripting.Dictionary")
Set sh = ThisWorkbook.Sheets("总表")
arr = sh.UsedRange
bt = 1 '//标题行数
col = 5 '//拆分列号
For i = bt + 1 To UBound(arr)
s = arr(i, col)
If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
d(s)(i) = Application.Index(arr, i)
Next
For Each k In d.keys
sh.Copy
Set wb = ActiveWorkbook
m = d(k).Count
With wb.Sheets(1)
.Name = k
.DrawingObjects.Delete
.UsedRange.Offset(bt + m).Clear
.Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k).Items, 1)
End With
wb.SaveAs p & k
wb.Close 1
Next
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

baofa2 · 发表于 2024-4-17 20:08

import pandas as pd
df = pd.read_excel('209901拆分另存模板.xlsm', header=0)
for key, value in df.groupby('公司'):
value.to_excel(f'{key}.xlsx', index=False)

复制代码

yynrzwh · 发表于 2024-4-17 22:16

楼主代码修改版

209901拆分另存模板.zip (39.29 KB, 下载次数: 3)
AI的代码也值得学习，比如：
dict.Add cellValue, Sheets.Add(After:=Sheets(Sheets.Count))
dict(cellValue).Name = cellValue

sys911066 · 发表于 2024-4-18 08:51

修改内容较多，辛苦各位老师了，内容我消化下，有问题再请教！谢谢！

sys911066 · 发表于 2024-4-18 12:01

limonet 发表于 2024-4-17 19:04
Sub limonet()
Dim S$, Cn As Object, StrSQL$, Arr As Variant, i%, FileFN$
S = Application.I ...

老师的程序是真的短和快，代码数量可见的少，用3000条数据拆分测试，人工计时测试，用时约为其他代码的10%。我想知道是哪一块程序让速度差异这么多呢？太牛了！

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

[求助] 关于按条件带格式拆分数据表的问题

评分

评分

评分

评分

评分

评分