求各位大佬怎么自动生成领料单

wang-way

sdytsxd991122 发表于 2024-6-15 20:19

左右开弓  同时练手 ？

咔咔乱坠

函数，参与一下
详见附件

山海风云轩

学习学习     

不闻z

gwjkkkkk 发表于 2024-6-15 19:35
Option Explicit

Sub TEST1()

好试试非常感谢老师

不闻z

LIUZHU 发表于 2024-6-15 19:42
参与下，效果

非常感谢老师

不闻z

quqiyuan 发表于 2024-6-15 19:55
参与一下，供参考。。。

非常感谢老师

不闻z

咔咔乱坠 发表于 2024-6-16 09:15
函数，参与一下
详见附件

厉害呀，这些公式貌似我都没学过

wang-way

练手

1. Rem 过程开始 X改为你想要的名字
   
2. Public Sub X()
   
3.     Rem 代码从这里开始写
   
4.     Rem 声明工作簿变量wb和工作表变量sht
   
5.     Rem 创建一个字典dic
   
6.     Set dic = CreateObject("Scripting.Dictionary")
   
7.     Dim wb As Workbook, sht As Worksheet
   
8.     Rem 设置wb为当前工作簿
   
9.     Set wb = Application.ThisWorkbook
   
10.     Rem 设置sht为指定名称的工作表，引号内填写工作表名称
    
11.     Set sht = wb.Worksheets("基础数据列表")
    
12.     Rem 设置psht为工作表，在引号内填写工作表名称
    
13.     Set psht = wb.Worksheets("领料模板")
    
14.     Rem 使用With语句，方便对工作表Sht进行多次操作
    
15.     With sht
    
16.         '.Usedrange.Offset(1).clear
    
17.         Rem 获取列A中最大数据行的行号
    
18.         eRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    
19.         Rem 设置范围从A2开始到Z列的eRow行结束
    
20.         Set Rng = .Range("A2:C" & eRow)
    
21.         Rem 将范围Rng的值赋给数组Arr
    
22.         arr = Rng.Value
    
23.         Rem 变量 i 从数组Arr最小索引开始，遍历至其最大索引
    
24.         For i = LBound(arr) To UBound(arr)
    
25.             Key = CStr(arr(i, 3))
    
26.             Rem 若字典dic中不存在键key 则执行
    
27.             If Not dic.Exists(Key) Then
    
28.                 Rem 创建一个字典d
    
29.                 Set d = CreateObject("Scripting.Dictionary")
    
30.             Else
    
31.                 Rem 若字典dic中存在键key 则执行
    
32.                 Set d = dic(Key)
    
33.             End If
    
34.             d(i) = Array(arr(i, 1), arr(i, 2))
    
35.             Set dic(Key) = d
    
36.         Next i
    
37.     End With
    
38.     For Each k In dic
    
39.         Rem 若后续代码出错，忽略错误继续执行
    
40.         On Error Resume Next
    
41.         'vvvvvvvvvvvvvv
    
42.         Rem 可能出错的语句放这里
    
43.         Rem 关闭警示弹窗
    
44.         Application.DisplayAlerts = False
    
45.         wb.Worksheets(k).Delete
    
46.         Rem 恢复警示弹窗
    
47.         Application.DisplayAlerts = True
    
48.         '^^^^^^^^^^
    
49.         Rem 若前面代码出错，恢复对错误的捕获
    
50.         On Error GoTo 0
    
51.         psht.Copy after:=wb.Worksheets(wb.Worksheets.Count)
    
52.         Rem 设置osht为工作表
    
53.         Set osht = wb.Worksheets(wb.Worksheets.Count)
    
54.         With osht
    
55.             .Name = k
    
56.             .Range("a4").Value = k
    
57.             Set d = dic(k)
    
58.             If d.Count > 5 Then .Range("a14").Resize(d.Count - 5, 1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
59.             Rem 设置范围为A2单元格
    
60.             Set Rng = .Range("A9").Resize(d.Count, 2)
    
61.             Rem 如果字典有元素，则将字典的项目转置后输出到指定范围Rng
    
62.             Rng.Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(d.items))
    
63.         End With
    
64.     Next k
    
65. End Sub
    
66. Rem 过程结束
    

复制代码

wang-way

练手

LIUZHU

wang-way 发表于 2024-6-17 09:01
练手

感觉没必要用with啊，模版复制后，当前活动工作表就是需要填入数据的表格，Range对象的操作都不需要前缀的