按报名表保存记录

绿色心情小天使

大家晚上好：
       附件中有一张报名表工作薄，有日期，报名名单、工时、备注四栏。
       现在需要：点保存按钮
      根据日期和名单把工时匹配到前面对应的表中，如下图：
      工时保存记录7.5.rar (27.98 KB, 下载次数: 7)

2023-7-6 20:21 上传

点击文件名下载附件

shiruiqiang

也有下面这种情况，都写上吧

ykcbf1100

附件供参考。。。

LIUZHU

JSA，也麻烦

LIUZHU

附加在此，WPS测试

绿色心情小天使

ykcbf1100 发表于 2023-7-6 20:57
附件供参考。。。

你好：
    还是有个小漏洞，如下：

    无人机工时.rar (46.85 KB, 下载次数: 2)

2023-7-7 15:32 上传

点击文件名下载附件

ykcbf1100

绿色心情小天使 发表于 2023-7-7 15:33
你好：
    还是有个小漏洞，如下：

加个判断就可以了。

绿色心情小天使

LIUZHU 发表于 2023-7-6 22:01
附加在此，WPS测试

怎么用不了

yynrzwh

1. Sub 圆角矩形1_Click()
   
2. 
   
3. arr = Sheets("报名表").UsedRange
   
4. Set d = CreateObject("scripting.dictionary")
   
5.     For i = 2 To UBound(arr)
   
6.         If arr(i, 2) <> "" Then
   
7.             m = Replace(Month(arr(i, 1)), "月", "") '获取月
   
8.             dd = Replace(Day(arr(i, 1)), "日", "") '获取日
   
9.             sp = Split(arr(i, 2), "、") '名单
   
10.                 For x = 0 To UBound(sp) '名单装入字典
    
11.                     d(sp(x)) = arr(i, 3)
    
12.                 Next x
    
13.             With Sheets(m) '对应月份的表
    
14.                 brr = .Range("B4:AG" & .Cells(Rows.Count, 2).End(3).Row - 1)
    
15.                 For j = 4 To UBound(brr)
    
16.                     brr(j, Val(dd) + 1) = d(brr(j, 1)) '根据名单写入工时
    
17.                 Next j
    
18.                 .Range("B4").Resize(UBound(brr), UBound(brr, 2)) = brr '数组写入工作表
    
19.             End With
    
20.             d.RemoveAll '清空字典
    
21.         End If
    
22.     Next i
    
23. Set d = Nothing
    
24. MsgBox "运行完毕"
    
25. End Sub
    

复制代码

chxw68

练习。。。