求助：跟进数据源，取特定数据，再分裂成不同的分表

cherry1314

各位老师好：

从系统导数数据源后，把标黄的数据对应复制到出库单上去，或者按照出库单的样式自动生成方便打印，请问代码可以实现吗？现在是手工一个一个复制粘贴，然后打印

limonet

与https://club.excelhome.net/forum ... 34&pid=11567127这个类似。

cherry1314

limonet 发表于 2024-9-23 11:33
与https://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=1699934&pid=11567127这个类似 ...

老师，这个它没有自动分裂成单独的工作表

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.9.23
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     For Each Sht In Sheets
   
6.         If InStr("领料|模板", Sht.Name) = 0 Then Sht.Delete
   
7.     Next
   
8.     With Sheets("领料")
   
9.         r = .Cells(Rows.Count, 1).End(3).Row
   
10.         c = .Cells(1, "XFD").End(1).Column
    
11.         arr = .[a1].Resize(r, c)
    
12.     End With
    
13.     For i = 2 To UBound(arr)
    
14.         s = arr(i, 6)
    
15.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
16.         d(s)(i) = ""
    
17.     Next
    
18.     For Each k In d.keys
    
19.         Sheets("模板").Copy After:=Sheets(Sheets.Count)
    
20.         Set Sht = Sheets(Sheets.Count)
    
21.         m = 0
    
22.         ReDim brr(1 To d(k).Count, 1 To 14)
    
23.         With Sht
    
24.             .Name = k
    
25.             .DrawingObjects.Delete
    
26.             For Each kk In d(k).keys
    
27.                 m = m + 1
    
28.                 If m = 1 Then
    
29.                     .[l5].Value = k
    
30.                     .[g6].Value = arr(kk, 5)
    
31.                     .[l6].Value = arr(kk, 8)
    
32.                     .[c7].Value = arr(kk, c)
    
33.                 End If
    
34.                 brr(m, 1) = m
    
35.                 brr(m, 2) = arr(kk, 17)
    
36.                 brr(m, 3) = arr(kk, 18)
    
37.                 brr(m, 4) = arr(kk, 19)
    
38.                 brr(m, 11) = arr(kk, 20)
    
39.                 brr(m, 12) = arr(kk, 21)
    
40.             Next
    
41.             If m > 3 Then
    
42.                 For i = 1 To m - 3
    
43.                     .Cells(9 + i, 1).EntireRow.Insert
    
44.                 Next i
    
45.             End If
    
46.             .[a9].Resize(m, 14) = brr
    
47.         End With
    
48.     Next
    
49.     Sheets("模板").Activate
    
50.     Set d = Nothing
    
51.     Application.ScreenUpdating = True
    
52.     MsgBox "OK！"
    
53. End Sub
    
54. 
    

复制代码

cherry1314

ykcbf1100 发表于 2024-9-23 12:21
附件供参考。。。

感谢，老师

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, i%, j%, k%, Rst As Object, Brr As Variant
    Set Cn = CreateObject("Adodb.Connection")
    Set Rst = CreateObject("adodb.recordset")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Arr = Cn.Execute("Select Distinct 出库单号 From [领料$]").GetRows
    For i = 0 To UBound(Arr, 2)
        Sheets("Template").Copy Before:=Sheets(Sheets.Count)
        ActiveSheet.Name = Arr(0, i)
        StrSQL = " From [领料$] Where 出库单号='" & Arr(0, i) & "'"
        Brr = Cn.Execute("Select 出库单号,业务号,出库日期,出库类别,项目名称" & StrSQL).GetRows(1)
        [L5].Value = Brr(0, 0): [C6] = Brr(1, 0): [G6] = Brr(2, 0): [L6] = Brr(3, 0): [C7] = Brr(4, 0)
        Rst.Open "Select 材料编码,材料名称,规格型号,Null,Null,Null,Null,Null,Null,主计量单位,数量" & StrSQL, Cn, 1, 3
        If Rst.RecordCount < 14 Then Rows((Rst.RecordCount + 9) & ":22").Delete
        Range("B9").CopyFromRecordset Rst: Rst.Close
    Next i
End Sub

limonet

关键字：rst.recordcount