求学代码

ykcbf1100

施学明 发表于 2024-9-10 20:56
谢谢你的全力相助，我认真学习下

完成需求2

ykcbf1100

工作表分批另存

1. Sub ykcbf2()   '//2024.9.11        工作表另存
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     p = ThisWorkbook.Path & ""
   
5.     p1 = p & "下拨批次"
   
6.     f = p & "批量下拨.xlsm"
   
7.     Set sh = ThisWorkbook.Sheets("转换")
   
8.     num = Val(sh.[b2].Value)
   
9.     rq = Format(Date, "yyyy-m-d")
   
10.     Set wb = Workbooks.Open(f, 0)
    
11.     With wb.Sheets(1)
    
12.         r = .Cells(Rows.Count, 1).End(3).Row
    
13.         c = .Cells(1, "XFD").End(1).Column
    
14.         arr = .[a1].Resize(r, c)
    
15.         bt = .[a1].Resize(, c)
    
16.     End With
    
17.     wb.Close 0
    
18.     k = r \ num + 1
    
19.     rr = 1    '//标题行数
    
20.     For x = 1 To k
    
21.         r1 = (x - 1) * num + 1 + rr
    
22.         If x = k Then r2 = UBound(arr) Else r2 = num * x + rr
    
23.         ReDim zrr(1 To num + 1, 1 To c)
    
24.         n = 0
    
25.         For i = r1 To r2
    
26.             n = n + 1
    
27.             For j = 1 To UBound(arr, 2)
    
28.                 zrr(n, j) = arr(i, j)
    
29.             Next
    
30.         Next
    
31.         Set wb = Workbooks.Add
    
32.         With wb.Sheets(1)
    
33.             .[a1].Resize(, c) = bt
    
34.             .[a2].Resize(n, c) = zrr
    
35.         End With
    
36.         wb.SaveAs p1 & rq & "批量下拨" & Format(x, "00")
    
37.         wb.Close
    
38.     Next
    
39.     Application.ScreenUpdating = True
    
40.     MsgBox "OK！"
    
41. End Sub
    

复制代码