选择√的项目显示到指定单元格，不选择的不显示，中间不能有空白。。

3190496160

糖↗小冷 发表于 2022-12-14 11:58
老师，你好，  评定依据的复选框与  F列的联动了，如何改？ I列的复选框需要单独执行，选择就有，不选择 ...

什么意思？？？评定依据要单独选择？那跟前面几项如何匹配呢？？
若果不需要评定依据，删除这句代码即可
arr(n, 12) = Cells(r, 7)

糖↗小冷

3190496160 发表于 2022-12-14 12:25
什么意思？？？评定依据要单独选择？那跟前面几项如何匹配呢？？
若果不需要评定依据，删除这句代码即可 ...

评定依据要单独选择，因为一个评定依据可以适用于好多个检验方法或者规程

于箱长

糖↗小冷 发表于 2022-12-14 13:45
评定依据要单独选择，因为一个评定依据可以适用于好多个检验方法或者规程

这表设计的吧，不是使用这个表格的人太难理解了，G列居然和前面几天不是直接对应的关系，还得根据选择情况判断？

太极拍天雄

纯练习一下，有合并单元格不好弄！

太极拍天雄

没注意到有两项要求，更新练习一下！

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     With Worksheets("类别")
   
5.         r = .Cells(.Rows.Count, 2).End(xlUp).Row
   
6.         arr = .Range("a4:f" & r)
   
7.         ReDim brr(1 To UBound(arr), 1 To 3)
   
8.         m = 0
   
9.         For i = 1 To UBound(arr)
   
10.             If Len(arr(i, 2)) <> 0 And arr(i, 5) = True Then
    
11.                 m = m + 1
    
12.                 brr(m, 1) = arr(i, 2)
    
13.                 brr(m, 2) = arr(i, 3)
    
14.                 brr(m, 3) = arr(i, 4)
    
15.             End If
    
16.         Next
    
17.         r = .Cells(.Rows.Count, 7).End(xlUp).Row
    
18.         arr = .Range("g4:i" & r)
    
19.         ReDim crr(1 To UBound(arr), 1 To 1)
    
20.         n = 0
    
21.         For i = 1 To UBound(arr)
    
22.             If arr(i, 2) = True Then
    
23.                 n = n + 1
    
24.                 crr(n, 1) = arr(i, 1)
    
25.             End If
    
26.         Next
    
27.     End With
    
28.     With Worksheets("委托书")
    
29.         .Range("h11:v30").ClearContents
    
30.         If m > 0 Then
    
31.             .Range("h11").Resize(m, 1) = Application.Index(brr, 0, 1)
    
32.             .Range("k11").Resize(m, 1) = Application.Index(brr, 0, 2)
    
33.             .Range("o11").Resize(m, 1) = Application.Index(brr, 0, 3)
    
34.         End If
    
35.         If n > 0 Then
    
36.             .Range("s11").Resize(n, 1) = crr
    
37.         End If
    
38.     End With
    
39. End Sub
    

复制代码

chxw68

详见附件。