求代码

施学明

需求：1将上缴工作簿的h，e，k列数据选择性粘贴到模版工作簿中工作表数据1中

      2 将模版中工作表的数据每满20行拆分为当前日期+支行上缴+序号命名的新工作簿

kyxfyzg

Sub shishi() Workbooks("上缴").Activate Set el = Range("e2:e" & Cells(Rows.Count, "e").End(3).Row) Set hl = Range("h2:h" & Cells(Rows.Count, "h").End(3).Row) Set kl = Range("k2:k" & Cells(Rows.Count, "k").End(3).Row) Workbooks("库存券别批量调拨 (模版)").Activate hl.Copy Range("b2") el.Copy Range("d2") kl.Copy Range("f2") h = Sheet1.UsedRange.Rows.Count Set bt = Rows(1) 当前日期 = Format(Date, "yyyy年m月d日") For i = 2 To h Step 20     n = n + 1     Set nr = Range("a" & i).Resize(20, 19)     Workbooks.Add     bt.Copy Range("a1")     nr.Copy Range("a2")     ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & 当前日期 & "支行上缴" & n & ".xlsx"     ActiveWorkbook.Close Next i End Sub

kyxfyzg

Sub shishi()
Workbooks("上缴").Activate
Set el = Range("e2:e" & Cells(Rows.Count, "e").End(3).Row)
Set hl = Range("h2:h" & Cells(Rows.Count, "h").End(3).Row)
Set kl = Range("k2:k" & Cells(Rows.Count, "k").End(3).Row)
Workbooks("库存券别批量调拨 (模版)").Activate
hl.Copy Range("b2")
el.Copy Range("d2")
kl.Copy Range("f2")
h = Sheet1.UsedRange.Rows.Count
Set bt = Rows(1)
当前日期 = Format(Date, "yyyy年m月d日")
For i = 2 To h Step 20
    n = n + 1
    Set nr = Range("a" & i).Resize(20, 19)
    Workbooks.Add
    bt.Copy Range("a1")
    nr.Copy Range("a2")
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & 当前日期 & "支行上缴" & n & ".xlsx"
    ActiveWorkbook.Close
Next i
End Sub

gwjkkkkk

数据直接放在模板中更方便一点。。。

ykcbf1100

附件供参考。。。

ykcbf1100

按模板拆分。。。

1. Sub ykcbf()   '//2024.8.1
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set sh = ThisWorkbook.Sheets("第一页")
   
5.     rq = FormatDateTime(Date, 1)
   
6.     With sh
   
7.         r = .Cells(Rows.Count, "e").End(3).Row
   
8.         c = .UsedRange.Columns.Count
   
9.         arr = .[a1].Resize(r, c)
   
10.     End With
    
11.     a = [{4,2,6}]
    
12.     b = [{5,8,11}]
    
13.     ReDim brr(1 To r, 1 To 6)
    
14.     For i = 2 To UBound(arr)
    
15.         m = m + 1
    
16.         For x = 1 To UBound(a)
    
17.             brr(m, a(x)) = arr(i, b(x))
    
18.         Next
    
19.     Next
    
20.     p = ThisWorkbook.Path & ""
    
21.     p1 = p & "拆分后"
    
22.     If Dir(p1, vbDirectory) = "" Then MkDir p1
    
23.     With Application.FileDialog(msoFileDialogFilePicker)
    
24.         .InitialFileName = p
    
25.         .Title = "请选择对应Excel文件"
    
26.         .AllowMultiSelect = False
    
27.         .Filters.Clear
    
28.         .Filters.Add "Excel文件", "*.xls*"
    
29.         If .Show Then f = .SelectedItems(1) Else Exit Sub
    
30.     End With
    
31.     Set wb = Workbooks.Open(f, 0)
    
32.     rr = 20
    
33.     col = 6
    
34.     bt = 1
    
35.     k = m \ rr + 1
    
36.     On Error Resume Next
    
37.     For x = 1 To k
    
38.         r1 = (x - 1) * rr + 1
    
39.         If x = k Then r2 = m Else r2 = rr * x
    
40.         ReDim zrr(1 To rr, 1 To col)
    
41.         n = 0
    
42.         For i = r1 To r2
    
43.             n = n + 1
    
44.             For j = 2 To UBound(brr, 2)
    
45.                 zrr(n, j) = brr(i, j)
    
46.             Next
    
47.         Next
    
48.         wb.Sheets(1).Copy
    
49.         Set wb1 = ActiveWorkbook
    
50.         With wb1.Sheets(1)
    
51.             .Range("B:B,d:d,F:F").NumberFormatLocal = "@"
    
52.             .Cells(bt + 1, 1).Resize(n, col) = zrr
    
53.         End With
    
54.         wb1.SaveAs p1 & rq & "支行上缴" & x
    
55.         wb1.Close
    
56.     Next
    
57.     wb.Close 0
    
58.     Application.ScreenUpdating = False
    
59.     Application.DisplayAlerts = False
    
60.     MsgBox "OK！"
    
61. End Sub
    
62. 
    

复制代码