求助按条件合并去重

我是小黑屋

1. Private Sub GetDate()
   
2. Dim i%, j%, c%
   
3. Dim Arr(1 To 1000, 1 To 8)
   
4. j = 2
   
5. With Me.ListView1
   
6.     For i = 1 To .ListItems.Count
   
7.         With .ListItems(i)
   
8.             If .Checked Then
   
9.             If c + 2 > 8 Then c = 2: j = j + 3 Else c = c + 2
   
10.                 If .SubItems(1) = "" Then
    
11.                     Arr(j, c) = .Text & "=" & .SubItems(3) & .SubItems(2)
    
12.                 Else
    
13.                     Arr(j, c) = .Text & "(" & .SubItems(1) & ")" & "=" & .SubItems(3) & .SubItems(2)
    
14.                 End If
    
15.                
    
16.                 Arr(j + 1, c) = .SubItems(5) & "号箱-" & "测试"
    
17.             End If
    
18.         End With
    
19.     Next
    
20. End With
    
21. Sheet23.UsedRange.ClearContents
    
22. Sheet23.Range("a1").Resize(j + 1, 8) = Arr
    
23. End Sub

复制代码

标签.zip (115.6 KB, 下载次数: 6)

2024-3-26 08:17 上传

点击文件名下载附件

清风竹-

请参考一下。

我是小黑屋

清风竹- 发表于 2024-3-26 10:11
请参考一下。

老师你好，可以在GetDate这个子程序中进行处理吗，我的应用场景是想根据勾选了的行才进行去重汇总，有可能当下我是希望勾选物料号中相同的其中一个是需要去打印出来的，那么这样数量就不对了。目前您修改的是在载入数据的时候就做处理了

清风竹-

我是小黑屋 发表于 2024-3-26 11:56
老师你好，可以在GetDate这个子程序中进行处理吗，我的应用场景是想根据勾选了的行才进行去重汇总，有可 ...

修改好了。

我是小黑屋

清风竹- 发表于 2024-3-26 15:13
修改好了。

非常感谢

我是小黑屋

清风竹- 发表于 2024-3-26 15:13
修改好了。

老师发现个小问题，勾选后的行，会将物料号是空的行，物料名称列是相同的时候也累计相加合并了。可以帮忙再看看吗？我需要勾选的行中，只有物料号那里是有内容的时候并且是物料号内容是相同的时候才进行累计相加

清风竹-

我是小黑屋 发表于 2024-3-30 10:59
老师发现个小问题，勾选后的行，会将物料号是空的行，物料名称列是相同的时候也累计相加合并了。可以帮忙 ...

请测试。


Private Sub GetDate()
Dim i%, j%, c%, ss, n%, cr, d, x, su
Dim Arr(1 To 1000, 1 To 8)

Set d = CreateObject("scripting.dictionary")
ReDim cr(1 To 1000, 1 To 8)
With Me.ListView1
    For i = 1 To .ListItems.Count
         With .ListItems(i)
            If .Checked Then
               If .SubItems(6) = "" Then
                  x = x + 1
                  su = "]" & x
                Else
                  su = .SubItems(6)
               End If
               ss = .Text & "|" & su
               If Not d.Exists(ss) Then
                    n = n + 1
                    d(ss) = n
                     cr(n, 1) = .Text
                    For j = 2 To 7
                      cr(n, j) = .SubItems(j - 1)
                    Next
                Else
                   cr(d(ss), 4) = --cr(d(ss), 4) + --.SubItems(3)
               End If
       End If
      End With
     Next
   End With
    j = 2
  
    For i = 1 To n
                If c + 2 > 8 Then c = 2: j = j + 3 Else c = c + 2
                 If cr(i, 2) = "" Then
                     Arr(j, c) = cr(i, 1) & "=" & cr(i, 4) & cr(i, 3)
                 Else
                     Arr(j, c) = cr(i, 1) & "(" & cr(i, 2) & ")" & "=" & cr(i, 4) & cr(i, 3)
                 End If
                 Arr(j + 1, c) = cr(i, 6) & "号箱-" & "测试" ''''''
    Next

Sheet23.UsedRange.ClearContents
Sheet23.Range("a1").Resize(j + 1, 8) = Arr
End Sub

我是小黑屋

清风竹- 发表于 2024-3-30 20:48
请测试。

非常感谢