表格拆分

36K纯帅 · 发表于 2024-6-14 13:44

各位老师好，之前在论坛看到过表格拆分的帖子，正好工作中有这个需求，自己试着修改了代码。

但实际运行发现还是有问题，自己也找不到原因，想知道问题出在哪？
我的需求挺简单：
有个设置表和总表（BOM表），想对BOM进行分阶处理（238、234、235即不同阶层），不同阶拆分为独立表格，依据为设置表A列内容与总表A列是否存在包含关系，同样阶层的物料信息放同一个工作表（如果总表C列包含“N/A”"双面板"“半成品”任一字段，则该行信息忽略不计）
问题点在于：
1.执行效率慢
2.分阶时出现错误
3.总表C列包含“N/A”"双面板"“半成品”的信息没有忽略

设置表：

总表：

ykcbf1100 · 发表于 2024-6-14 14:47

本帖最后由 ykcbf1100 于 2024-6-14 14:55 编辑

总表拆分为多表，字典+正则，秒拆

附件供参考。。。

ykcbf1100 · 发表于 2024-6-14 14:48

参与一下。。。

Sub ykcbf() '//2024.6.14
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("Scripting.Dictionary")
Set sh = ThisWorkbook.Sheets("总表")
Set reg = CreateObject("VBScript.Regexp")
arr = Sheets("设置").UsedRange
For Each sht In Sheets
If sht.Name <> "设置" And sht.Name <> "总表" Then
sht.Delete
End If
Next
For i = 2 To UBound(arr)
If arr(i, 1) <> Empty Then
d(arr(i, 1)) = ""
End If
Next
With reg
.Global = False
.Pattern = "N/A|双面板|半成品"
End With
With sh
r = .Cells(Rows.Count, 1).End(3).Row
c = .UsedRange.Columns.Count
arr = .[a1].Resize(r, c)
End With
For Each k In d.keys
Sheets.Add(After:=Sheets(Sheets.Count)).Name = k
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
m = 0
With Sheets(k)
sh.Cells.Copy .[a1]
.UsedRange.Offset(1).Clear
For i = 2 To UBound(arr)
If arr(i, 1) = k Then
If Not reg.test(arr(i, 3)) Then
m = m + 1
For j = 1 To UBound(arr, 2)
brr(m, j) = arr(i, j)
Next
End If
End If
Next
.[a2].Resize(m, UBound(arr, 2)) = brr
End With
Next
Sheets("设置").Activate
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

3190496160 · 发表于 2024-6-14 15:15

Sub 拆分()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant, br As Variant
Dim i As Long, r As Long, rs As Long
Dim cr(), brr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set sht = Sheets("总表")
With Sheets("设置")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "设置工作表为空！": End
ar = .Range("a1:a" & r)
End With
For i = 2 To UBound(ar)
If ar(i, 1) <> "" Then
      d(ar(i, 1)) = ""
End If
Next i
With sht
rs = .Cells(Rows.Count, 1).End(xlUp).Row
If rs < 2 Then MsgBox "总表工作表为空！": End
br = .Range("a1:f" & rs)
End With
For i = 2 To UBound(br)
If br(i, 1) <> "" Then
      If Not IsError(br(i, 3)) Then
         If br(i, 3) <> "双面板" And br(i, 3) <> "半成品" Then
            If d.exists(br(i, 1)) Then
                  If Not dc.exists(br(i, 1)) Then Set dc(br(i, 1)) = CreateObject("scripting.dictionary")
                  dc(br(i, 1))(i) = i
            End If
         End If
      End If
End If
Next i
For Each sh In Sheets
If sh.Index > 2 Then
      sh.Delete
End If
Next sh
For Each k In dc.keys
n = 0
ReDim cr(1 To UBound(br), 1 To UBound(br, 2))
For Each kk In dc(k).keys
      n = n + 1
      For j = 1 To UBound(br, 2)
         cr(n, j) = br(kk, j)
      Next j
Next kk
sht.Copy after:=Sheets(Sheets.Count)
With ActiveSheet
      .Name = k
      .[a1].CurrentRegion.Offset(1) = Empty
      .[a2].Resize(n, UBound(cr, 2)) = cr
End With
Next k
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "ok!"
End Sub

3190496160 · 发表于 2024-6-14 15:16

表格拆分.rar (44.63 KB, 下载次数: 3)

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