按照条件部门拆分，并单独文件。

yi860214

帮忙写一段VBA代码，烦请查收文件和结果见附件，谢谢。

1）删除GRAND TTL:和页码对应的行。
2）每TTL AMT: 一个部门的拆分。拆分指定的文件夹后的文件名为部门号后面的 C列的没有数量的值。

ykcbf1100

拆分工作表为多工作簿

ykcbf1100

拆分。。。。

1. Sub ykcbf()   '//2024.7.29   拆分
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     p = ThisWorkbook.Path & "\拆分结果"
   
6.     Set sh = ThisWorkbook.Sheets("Sheet")
   
7.     arr = sh.UsedRange
   
8.     For i = 1 To UBound(arr)
   
9.         If arr(i, 1) = Empty And arr(i, 2) > 0 Then k = k + 1: d(k) = i
   
10.     Next
    
11.     For k = 1 To d.Count
    
12.         r1 = d(k)
    
13.         If k = d.Count Then r2 = UBound(arr) Else r2 = d(k + 1) - 1
    
14.         fn = Trim(arr(r1, 3))
    
15.         sh.Copy
    
16.         Set wb = ActiveWorkbook
    
17.         With wb.Sheets(1)
    
18.             Set Rng = Nothing
    
19.             .DrawingObjects.Delete
    
20.             For i = 10 To UBound(arr)
    
21.                 If i < r1 Or i > r2 Then
    
22.                     If Rng Is Nothing Then
    
23.                         Set Rng = .Rows(i)
    
24.                     Else
    
25.                         Set Rng = Union(Rng, .Rows(i))
    
26.                     End If
    
27.                 End If
    
28.             Next i
    
29.             If Not Rng Is Nothing Then Rng.EntireRow.Delete
    
30.         End With
    
31.         wb.SaveAs p & fn
    
32.         wb.Close
    
33.     Next
    
34.     Set d = Nothing
    
35.     Application.ScreenUpdating = True
    
36.     MsgBox "OK！"
    
37. End Sub
    

复制代码

yi860214

ykcbf1100 发表于 2024-7-29 15:24
拆分工作表为多工作簿

多谢。学习了。这个对哦，这代码可以。就是GRAND TTL:一行没删除。还有个问题，就是如果标题有图片的话，如何解决呀。

ykcbf1100

yi860214 发表于 2024-7-29 15:54
多谢。学习了。这个对哦，这代码可以。就是GRAND TTL:一行没删除。还有个问题，就是如果标题有图片的话， ...

改好了。。。

ykcbf1100

更新一下。。。

1. Sub ykcbf()   '//2024.7.29   拆分
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     p = ThisWorkbook.Path & "\拆分结果"
   
6.     Set sh = ThisWorkbook.Sheets("Sheet")
   
7.     With sh
   
8.         arr = sh.UsedRange
   
9.         rr = .UsedRange.Find("GRAND TTL:").Row
   
10.     End With
    
11.     For i = 1 To UBound(arr)
    
12.         If arr(i, 1) = Empty And arr(i, 2) > 0 Then k = k + 1: d(k) = i
    
13.     Next
    
14.     On Error Resume Next
    
15.     For k = 1 To d.Count
    
16.         r1 = d(k)
    
17.         If k = d.Count Then r2 = UBound(arr) Else r2 = d(k + 1) - 1
    
18.         fn = Trim(arr(r1, 3))
    
19.         sh.Copy
    
20.         Set wb = ActiveWorkbook
    
21.         With wb.Sheets(1)
    
22.             Set Rng = Nothing
    
23.             .UsedRange.Offset(8).DrawingObjects.Delete
    
24.             .UsedRange.Offset(rr - 1).Clear
    
25.             For i = 10 To UBound(arr)
    
26.                 If i < r1 Or i > r2 Then
    
27.                     If Rng Is Nothing Then
    
28.                         Set Rng = .Rows(i)
    
29.                     Else
    
30.                         Set Rng = Union(Rng, .Rows(i))
    
31.                     End If
    
32.                 End If
    
33.             Next i
    
34.             If Not Rng Is Nothing Then Rng.EntireRow.Delete
    
35.         End With
    
36.         wb.SaveAs p & fn
    
37.         wb.Close
    
38.     Next
    
39.     Set d = Nothing
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "OK！"
    
42. End Sub
    

复制代码

yi860214

ykcbf1100 发表于 2024-7-29 16:34
改好了。。。

多谢，可以了。