|
|
Sub 拆分为多薄多表()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim br(), brr()
Dim rn As Range, rng As Range
Dim d As Object
Set d = CreateObject("scripting.dictionary")
For Each sh In Sheets
y = sh.Cells(1, Columns.Count).End(xlToLeft).Column
Set rn = sh.Rows("1:2").Find("产品名称", , , , , , 1)
If rn Is Nothing Then MsgBox sh.Name & "工作表的第一行没有 产品名称 字段，请核查后重试！": End
h = rn.Column
r = sh.Cells(Rows.Count, h).End(xlUp).Row
ar = sh.Range(sh.Cells(1, 1), sh.Cells(r, y))
For i = 2 To UBound(ar)
If Trim(ar(i, h)) <> "" Then
d(Trim(ar(i, h))) = ""
End If
Next i
Next sh
For Each k In d.keys
m = 0
For Each sh In Sheets
m = m + 1
y = sh.Cells(1, Columns.Count).End(xlToLeft).Column
Set rn = sh.Range("a1").Resize(2, y).Find("产品名称", , , , , , 1)
If rn Is Nothing Then MsgBox sh.Name & "工作表的第一行没有 产品名称 字段，请核查后重试！": End
h = rn.Column
r = sh.Cells(Rows.Count, h).End(xlUp).Row
ar = sh.Range(sh.Cells(1, 1), sh.Cells(r, y))
If m = 1 Then
sh.Copy
Set wb = ActiveWorkbook
Else
sh.Copy after:=wb.Worksheets(wb.Worksheets.Count)
End If
With wb.ActiveSheet
For i = 2 To UBound(ar)
If Trim(ar(i, h)) <> k Then
If rng Is Nothing Then
Set rng = .Rows(i)
Else
Set rng = Union(rng, .Rows(i))
End If
End If
Next i
End With
If Not rng Is Nothing Then rng.Delete
Set rng = Nothing
Next sh
wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k & ".xlsx"
wb.Close
Next k
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-1-19 11:21
楼主
