有偿求助

凌空一羽

生成工作簿……

1. Sub lkyy()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. myr = Range("a10000").End(3).Row
   
4. For i = 1 To myr Step 36
   
5.     If Cells(i, "p") <> "" Then d(Cells(i, "p").Value) = i
   
6. Next
   
7. If d.Count = 0 Then MsgBox "不存在": Exit Sub
   
8. Application.DisplayAlerts = False
   
9. Sheets.Copy after:=Sheets("Page1")
   
10. ActiveSheet.Name = "复制"
    
11. With Sheets("复制")
    
12.     .Range("a1:v" & myr).ClearContents
    
13.     .Range("a37:v" & myr).Borders.LineStyle = 0
    
14.     For Each shp In .Shapes
    
15.         If TypeName(shp) = "Shape" Then shp.Delete
    
16.     Next
    
17. End With
    
18. For i = 0 To d.Count - 1
    
19.     Set wb = Workbooks.Add
    
20.     wb.SaveAs ThisWorkbook.Path & "" & d.keys()(i) & ".xlsx"
    
21.     ThisWorkbook.Sheets("复制").Copy wb.Sheets(1)
    
22.     With wb.Sheets("复制")
    
23.         .Range("1:36").RowHeight = 20.75
    
24.         ThisWorkbook.Sheets("Page1").Cells(d.items()(i), 1).Resize(36, 22).Copy .[a1]
    
25.         .Name = d.keys()(i)
    
26.     End With
    
27.     wb.Close 1
    
28. Next
    
29. Set d = Nothing
    
30. ThisWorkbook.Sheets("复制").Delete
    
31. Application.DisplayAlerts = True
    
32. End Sub
    

复制代码

Excel__Boy

请测试结果及结果条码

1. Sub dex()
   
2. Dim wk As Workbook
   
3. Dim sh As Worksheet
   
4. Dim i, r
   
5. Dim sp As Shape
   
6. Application.ScreenUpdating = False
   
7. r = Cells(Rows.Count, 1).End(xlUp).Row
   
8. Set sh = ActiveSheet
   
9. For i = 1 To r - 1 Step 36
   
10.     Set wk = Workbooks.Add
    
11.     sh.Copy Before:=wk.Sheets(1)
    
12.     For Each sp In wk.Sheets(1).Shapes
    
13.         If sp.TopLeftCell.Row <> i And sp.TopLeftCell.Row <> i + 1 Then sp.Delete
    
14.         
    
15.         
    
16.     Next sp
    
17.     If i = 1 Then
    
18.         wk.Sheets(1).Rows("37:" & r).Delete
    
19.     Else
    
20.         wk.Sheets(1).Rows("1:" & i - 1).Delete
    
21.         wk.Sheets(1).Rows("37:" & r).Delete
    
22.     End If
    
23.     wk.SaveAs ThisWorkbook.Path & "" & wk.Sheets(1).Cells(1, "P") & ".xlsx"
    
24.     wk.Close True
    
25. Next i
    
26. Application.ScreenUpdating = True
    
27. End Sub
    

复制代码