还是求助表格拆分

sunny_8848

上次请教大家表格拆分的事情，这次是按所在行拆分，保持第一行的内容。需要拆分的行数不定，是A列A2开始有内容的行

[attach]307 5648[/attach]

ykcbf1100

按原格式拆分

ykcbf1100

总表拆分

1. Sub ykcbf()   '//2024.11.14
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim t: t = Timer
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     p = ThisWorkbook.Path & ""
   
7.     arr = sh.UsedRange
   
8.     For i = 2 To UBound(arr)
   
9.         If arr(i, 1) <> Empty Then
   
10.             sh.Copy
    
11.             Set wb = ActiveWorkbook
    
12.             With wb.Sheets(1)
    
13.                 .AutoFilterMode = False
    
14.                 .DrawingObjects.Delete
    
15.                 .Rows("1:1").AutoFilter
    
16.                 .Cells(1, 1).AutoFilter Field:=1, Criteria1:="<>" & arr(i, 1)
    
17.                 .Cells(2, 1).Resize(UBound(arr) - 1).EntireRow.Delete
    
18.                 .AutoFilterMode = False
    
19.             End With
    
20.             wb.SaveAs p & arr(i, 1)
    
21.             wb.Close
    
22.         End If
    
23.     Next
    
24.     Application.ScreenUpdating = True
    
25.     Application.DisplayAlerts = True
    
26.     MsgBox "拆分完毕，共用时： " & Format(Timer - t, "0.000秒"), , "提示"
    
27. End Sub
    

复制代码

Qs18

1. Sub qs()
   
2. Application.ScreenUpdating = False: Application.DisplayAlerts = False
   
3. Dim rng As Range, sht As Worksheet, wb As Workbook, p
   
4. p = ThisWorkbook.Path & ""
   
5. With Sheet1
   
6. 
   
7. For i = 2 To .Cells(Rows.Count, 1).End(3).Row
   
8. Set rng = Sheet1.Rows("1:1")
   
9.     Set rng = Union(rng, .Rows(i & ":" & i))
   
10.     Workbooks.Add
    
11.     Set wb = ActiveWorkbook
    
12.     rng.Copy wb.Sheets(1).[a1]
    
13.     wb.SaveAs p & .Range("a" & i).Value
    
14.     wb.Close
    
15. Set rng = Nothing
    
16. Next
    
17. End With
    
18. Application.ScreenUpdating = True: Application.DisplayAlerts = True
    
19. End Sub
    

复制代码

Qs18

试试...........

Qs18

试试........

sunny_8848

Qs18 发表于 2024-11-14 15:36
试试...........

多谢帮忙，公式也可以运行，要是格式能保存下来就更好了。

sunny_8848

Qs18 发表于 2024-11-14 15:37
试试........

多谢帮忙，公式也可以运行，要是格式能保存下来就更好了

sunny_8848

ykcbf1100 发表于 2024-11-14 15:07
按原格式拆分

谢谢您的帮忙，因为表格里面有些公式，所以要先把公式改成数值

sunny_8848

ykcbf1100 发表于 2024-11-14 15:07
按原格式拆分

谢谢您的帮忙，因为表格里面有些公式，所以要先把公式改成数值，但要保持总表的公式