[已解决]请教：每个表各取1行合并去重，及计算

lygyjt

请教：表1、2所有数据，是由01~99文本数据组成，每行个数及行数是变量。每个表各取1行，进行合并去重，然后按从小到大排列放到“合并去重”表，遍历表1、2。在AY输入一个数值（假设79），首先将“合并去重”表中完全相同的行去重，并将数据个数大于79的行删除掉，最后将结果放到“删除相同行及指定个数行”中。按按钮，完成上述动作。例如：
        表1取出第1行，与表2第1行组合并去重后，按从小到大排列放在“合并去重”表的第1行；然后与表2第2行组合并去重后，按从小到大排列放在“合并去重”表的第2行；直到与表2最后1行行组合并去重后，按从小到大排列放在“合并去重”表的第x行。
        表1取出第2行，与表2第1行组合并去重后，按从小到大排列放在“合并去重”表的第1行；然后与表2第2行组合并去重后，按从小到大排列放在“合并去重”表的第2行；直到与表2最后1行行组合并去重后，按从小到大排列放在“合并去重”表的第y行。
        以此类推，直到表1完成最后1行。
        “合并去重”表中是手动计算的例子。 两表各取1行，进行组合去重及相关计算.rar (15.02 KB, 下载次数: 4)

2021-7-31 16:29 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

cutecpu

2021-7-31 16:29

Sub demo()
   Set list1 = CreateObject("System.Collections.ArrayList")
   Set d = CreateObject("Scripting.Dictionary")
   Sheets(3).UsedRange.ClearContents
   a = Sheets(1).UsedRange
   b = Sheets(2).UsedRange
   For i = 1 To UBound(a)
      For k = 1 To UBound(a, 2)
         Key = a(i, k): If Key = 0 Then Exit For
         If Not list1.contains(Key) Then list1.Add Key
      Next
      For j = 1 To UBound(b)
         Set list2 = list1.Clone
         For k = 1 To UBound(b, 2)
            Key = b(j, k): If Key = 0 Then Exit For
            If Not list2.contains(Key) Then list2.Add Key
         Next
         list2.Sort
         r = r + 1
         Sheets(3).Cells(r, 1).Resize(1, list2.Count) = list2.ToArray
      Next
      list1.Clear
   Next
   Sheets(4).UsedRange.Offset(1, 0).ClearContents
   ay = Sheets(4).[ay1]
   r = 1
   With Sheets(3)
      For i = 1 To .[a1].End(4).Row
         c = .Cells(i, 1).End(2).Column
         If c > ay Then GoTo 1
         Set Rng = Range(.Cells(i, 1), .Cells(i, c))
         Key = Join(Application.Transpose(Application.Transpose(Rng)))
         If Not d.exists(Key) Then
            d(Key) = 1
            r = r + 1
            Sheets(4).Cells(r, 1).Resize(1, c).Value = Rng.Value
         End If
1:
      Next
   End With
End Sub

祝順心，南無阿彌陀佛！

跳转到最佳答案楼层

cutecpu

Sub demo()
   Set list1 = CreateObject("System.Collections.ArrayList")
   Set d = CreateObject("Scripting.Dictionary")
   Sheets(3).UsedRange.ClearContents
   a = Sheets(1).UsedRange
   b = Sheets(2).UsedRange
   For i = 1 To UBound(a)
      For k = 1 To UBound(a, 2)
         Key = a(i, k): If Key = 0 Then Exit For
         If Not list1.contains(Key) Then list1.Add Key
      Next
      For j = 1 To UBound(b)
         Set list2 = list1.Clone
         For k = 1 To UBound(b, 2)
            Key = b(j, k): If Key = 0 Then Exit For
            If Not list2.contains(Key) Then list2.Add Key
         Next
         list2.Sort
         r = r + 1
         Sheets(3).Cells(r, 1).Resize(1, list2.Count) = list2.ToArray
      Next
      list1.Clear
   Next
   Sheets(4).UsedRange.Offset(1, 0).ClearContents
   ay = Sheets(4).[ay1]
   r = 1
   With Sheets(3)
      For i = 1 To .[a1].End(4).Row
         c = .Cells(i, 1).End(2).Column
         If c > ay Then GoTo 1
         Set Rng = Range(.Cells(i, 1), .Cells(i, c))
         Key = Join(Application.Transpose(Application.Transpose(Rng)))
         If Not d.exists(Key) Then
            d(Key) = 1
            r = r + 1
            Sheets(4).Cells(r, 1).Resize(1, c).Value = Rng.Value
         End If
1:
      Next
   End With
End Sub

祝順心，南無阿彌陀佛！

lygyjt

cutecpu 发表于 2021-7-31 16:29
Sub demo()
   Set list1 = CreateObject("System.Collections.ArrayList")
   Set d = CreateObject("Sc ...

再次感谢版主的厚爱！版主的深仁厚泽，日后定当效仿。

lygyjt

cutecpu 发表于 2021-7-31 16:29
Sub demo()
   Set list1 = CreateObject("System.Collections.ArrayList")
   Set d = CreateObject("Sc ...

版主，当在AY1输入15，然后按按钮时，在“删除相同行及指定个数行”表中，并未删除那些数据个数大于15的行。请版主方便时，再看下行吗？

cutecpu

lygyjt 发表于 2021-8-1 16:03
版主，当在AY1输入15，然后按按钮时，在“删除相同行及指定个数行”表中，并未删除那些数据个数大于15的 ...

AY1 的格式 改成數字即可

lygyjt

cutecpu 发表于 2021-8-1 16:10
AY1 的格式 改成數字即可

哈哈，让版主见笑喽，嘿嘿

cutecpu

lygyjt 发表于 2021-8-1 16:12
哈哈，让版主见笑喽，嘿嘿

那個是我調的，因為原來 AY1 是 79
所以我把 A ~ CA 列都變文字格式
但忘記把 AY1 調回來