根据A列拆分成新的工作簿里的多个工作表

cnkele · 发表于 2024-4-21 14:25

按下按钮直接根据A列内容拆分成新的工作簿里的多个工作表，同时删除V列开始的所有内容，并跳转为当前打开状态，或者直接跳出另存为界面，谢谢指教

ykcbf1100 · 发表于 2024-4-21 14:36

你的意思是新的工作簿不退出吧。

cnkele · 发表于 2024-4-21 14:42

ykcbf1100 发表于 2024-4-21 14:36
你的意思是新的工作簿不退出吧。

直接打开新的工作簿，或者新工作簿另存为的界面都可以

shiruiqiang · 发表于 2024-4-21 14:44

ykcbf1100 发表于 2024-4-21 14:36
你的意思是新的工作簿不退出吧。

应该是产生一个新的工作簿里、多表就行

ykcbf1100 · 发表于 2024-4-21 14:55

shiruiqiang 发表于 2024-4-21 14:44
应该是产生一个新的工作簿里、多表就行

附件供参考，新工作簿要保存为“工作簿另存”。

ykcbf1100 · 发表于 2024-4-21 14:57

参与一下。。。

Sub ykcbf2() '//2024.4.21
Dim arr, brr, d
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim tm: tm = Timer
Set ws = ThisWorkbook
Set sh = ws.Sheets("成绩确认")
p = ThisWorkbook.Path & ""
bt = 2
arr = sh.UsedRange
For i = 3 To UBound(arr)
s = arr(i, 1)
If s <> Empty Then
If Not d.Exists(s) Then
Set d(s) = CreateObject("scripting.dictionary")
End If
d(s)(i) = Application.Index(arr, i)
End If
Next i
Application.SheetsInNewWorkbook = d.Count
Set wb = Workbooks.Add
For Each k In d.keys
n = n + 1
Set sht = wb.Sheets(n)
m = d(k).Count
With sht
sh.Cells.Copy .[a1]
.Name = k
.UsedRange.Offset(m + bt).Clear
.[v:Z].Delete
.[v3:w3] = ""
.DrawingObjects.Delete
.Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k).Items, 1)
End With
Next k
wb.SaveAs p & "工作簿另存"
' sh.Activate
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "共用时：" & Format(Timer - tm) & "秒！"
End Sub

复制代码

cnkele · 发表于 2024-4-21 15:22

ykcbf1100 发表于 2024-4-21 14:55
附件供参考，新工作簿要保存为“工作簿另存”。

测试完美，非常感谢

cnkele · 发表于 2024-4-21 15:33

本帖最后由 cnkele 于 2024-4-21 15:34 编辑

第一个工作表里没有删除V列后面的，其他工作表删除了，是不是删除[v:Z].Delete这段代码里少了啥？

Sub 成绩打印另存() '//2024.4.21
Dim arr, brr, d
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim tm: tm = Timer
Set ws = ThisWorkbook
Set sh = ws.Sheets("学生签名")
p = ThisWorkbook.Path & ""
bt = 2
arr = sh.UsedRange
For i = 3 To UBound(arr)
s = arr(i, 1)
If s <> Empty Then
If Not d.Exists(s) Then
Set d(s) = CreateObject("scripting.dictionary")
End If
d(s)(i) = Application.Index(arr, i)
End If
Next i
Application.SheetsInNewWorkbook = d.Count
Set wb = Workbooks.Add
For Each k In d.keys
n = n + 1
Set sht = wb.Sheets(n)
m = d(k).Count
With sht
sh.Cells.Copy .[a1]
.Name = k
.UsedRange.Offset(m + bt).Clear
.[v:Z].Delete
.[v3:w3] = ""
.DrawingObjects.Delete
.Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k).Items, 1)
End With
Next k
wb.SaveAs p & "工作簿另存"
' sh.Activate
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "共用时：" & Format(Timer - tm) & "秒！"
End Sub

复制代码

cnkele · 发表于 2024-4-21 15:39

ykcbf1100 发表于 2024-4-21 14:57
参与一下。。。

新工作簿第一个工作表没有删除V列后面的内容

baofa2 · 发表于 2024-4-21 15:48

Sub test1()
Dim data, rowHeights() As Double, dict As Object
Dim i As Long, j As Long, vKey As Variant
Dim dstFolder As String, ws As String
Dim titleRow As Long, splitCol As Long
DoApp False
titleRow = 2
splitCol = 1
j = 21
ReDim rowHeights(1 To titleRow + 1)
dstFolder = ThisWorkbook.Path & "\"
Set dict = CreateObject("Scripting.Dictionary")
With ActiveSheet
data = .Range("A1").CurrentRegion.Resize(, j).Value
For i = titleRow + 1 To UBound(data)
ws = data(i, splitCol)
If Not dict.Exists(ws) Then Set dict(ws) = .Range("A1").Resize(titleRow, j)
Set dict(ws) = Union(dict(ws), .Range("A" & i).Resize(, j))
Next
For j = 1 To UBound(data, 2)
data(1, j) = .Columns(j).ColumnWidth
Next
For i = 1 To UBound(rowHeights)
rowHeights(i) = .Rows(i).RowHeight
Next
End With
j = 0
Application.SheetsInNewWorkbook = dict.Count
With Workbooks.Add
For Each vKey In dict.Keys
j = j + 1
With .Worksheets(j)
dict(vKey).Copy .Range("A1")
.Name = vKey
For i = 1 To UBound(data, 2)
.Columns(i).ColumnWidth = data(1, i)
Next
For i = 1 To UBound(rowHeights) - 1
.Rows(i).RowHeight = rowHeights(i)
Next
.Rows(i & ":" & .UsedRange.Rows.Count).RowHeight = rowHeights(i)
.DrawingObjects.Delete
End With
Next
.SaveAs dstFolder & Split(ThisWorkbook.Name, ".xls")(0) & "-拆分副本", 51
.Close
End With
'Next
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText ""
.PutInClipboard
End With
Set dict = Nothing
Application.SheetsInNewWorkbook = 1
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

复制代码

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

[求助] 根据A列拆分成新的工作簿里的多个工作表

评分