按内容批量生成工作表

zllyyz · 发表于 2024-1-28 22:23

如题，按内容批量生成工作表（内容有重复项的，只按一个内容生成一个工作表与名称），且需按《模板》，将相关数据一同带过去，期待大师佳作，谢谢

3190496160 · 发表于 2024-1-29 08:03

其实就是一个按品名拆分为多个工作表的问题，你的模板跟数据源结构是完全一致的，没有必要再用模板，
论坛拆分的帖子很多，自己搜搜看看呗，
或者，到我的主题里面去找找，几个拆分工具一定有一个适合你的

liulang0808 · 发表于 2024-1-29 08:19

Sub 按钮1_Click()
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
arr = Sheets("明细表").UsedRange
Sheets("明细表").Select
For Each sh In Sheets
      If sh.Name <> "明细表" And sh.Name <> "模板" Then sh.Delete
Next sh
For j = 3 To UBound(arr)
      If d.exists(arr(j, 3)) Then
         Set d(arr(j, 3)) = Union(d(arr(j, 3)), Cells(j, 1))
      Else
         Set d(arr(j, 3)) = Cells(j, 1)
      End If
Next j
For Each k In d.keys
      Sheets("模板").Copy after:=Sheets(Sheets.Count)
      d(k).EntireRow.Copy Sheets(Sheets.Count).[a3]
      Sheets(Sheets.Count).Name = k
Next k
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

liulang0808 · 发表于 2024-1-29 08:19

按内容批量生成工作表.zip (32.86 KB, 下载次数: 23)

ykcbf1100 · 发表于 2024-1-29 08:40

参与一下。。。

Sub ykcbf() '//2024.1.29
Dim arr, brr, d
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim tm: tm = Timer
Set sh = Sheets("明细表")
For Each sht In Sheets
If sht.Name <> sh.Name Then
sht.Delete
End If
Next
arr = sh.UsedRange
For i = 3 To UBound(arr)
s = arr(i, 3)
If Not d.Exists(s) Then
Set d(s) = CreateObject("scripting.dictionary")
End If
d(s)(i) = i
Next i
For Each k In d.keys
m = 0
ReDim brr(1 To d(k).Count, 1 To 4)
sh.Copy after:=Sheets(Sheets.Count)
Set sht = Sheets(Sheets.Count)
With sht
.Name = k
.DrawingObjects.Delete
For Each kk In d(k).keys
m = m + 1
brr(m, 1) = m
For j = 2 To 4
brr(m, j) = arr(kk, j)
Next
Next
.Range("A5").Resize(m, 4) = brr
.UsedRange.Offset(m + 2).Clear
End With
Next k
sh.Activate
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "共用时：" & Format(Timer - tm) & "秒！"
End Sub

复制代码

ykcbf1100 · 发表于 2024-1-29 08:41

附件供参考。。。

zllyyz · 发表于 2024-1-29 10:28

liulang0808 发表于 2024-1-29 08:19
Sub 按钮1_Click()
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating ...

完美解决 DDDDDDDDDDD

zllyyz · 发表于 2024-1-29 10:30

3190496160 发表于 2024-1-29 08:03
其实就是一个按品名拆分为多个工作表的问题，你的模板跟数据源结构是完全一致的，没有必要再用模板，
论坛 ...

感谢提醒谢谢

lizhipei78 · 发表于 2024-1-29 11:07

https://club.excelhome.net/threa ... tml?_dsign=59ea1e22

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

[求助] 按内容批量生成工作表

评分

评分