求一个把上下2行相同的数字提出来的VBA,谢谢

飞越一切

结果显示在对应的右边
相同数字提出来.rar (7.84 KB, 下载次数: 12)

2024-8-28 17:03 上传

点击文件名下载附件

饮冰e士

是这个意思？

飞越一切

饮冰e士 发表于 2024-8-28 17:22
是这个意思？

能不能数字排一起，中间不要空的单元格

Excel_muke

这样吗？

1. Sub ExtractMatchingNumbersBetweenRows()
   
2.     Dim ws As Worksheet
   
3.     Dim sourceRange As Range
   
4.     Dim destCell As Range
   
5.     Dim i As Long, j As Long, k As Long
   
6.     Dim lastRow As Long
   
7.     Dim matchCount As Long
   
8.    
   
9.     ' 设置要操作的工作表
   
10.     Set ws = ThisWorkbook.Sheets("Sheet1") ' 请根据需要修改工作表名称
    
11.    
    
12.     ' 设置源范围和目标范围
    
13.     Set sourceRange = ws.Range("B2:U8") ' 请根据需要修改源范围
    
14.     Set destCell = ws.Range("W2") ' 请根据需要修改目标范围起点
    
15.    
    
16.     ' 清除目标范围的旧数据
    
17.     ws.Range(destCell, destCell.Offset(sourceRange.Rows.Count - 1, sourceRange.Columns.Count - 1)).ClearContents
    
18.    
    
19.     ' 获取源范围的最后一行
    
20.     lastRow = sourceRange.Rows.Count
    
21.    
    
22.     ' 从第二行开始遍历每一行数据，与上一行进行比较
    
23.     For i = 2 To lastRow
    
24.         matchCount = 0
    
25.         
    
26.         ' 遍历上一行的每个数字
    
27.         For j = 1 To sourceRange.Columns.Count
    
28.             ' 遍历当前行的每个数字
    
29.             For k = 1 To sourceRange.Columns.Count
    
30.                 If sourceRange.Cells(i, k).Value = sourceRange.Cells(i - 1, j).Value Then
    
31.                     ' 如果找到相同的数字，将其写入目标范围，避免重复写入
    
32.                     If Not IsEmpty(sourceRange.Cells(i, k).Value) Then
    
33.                         destCell.Cells(i, matchCount + 1).Value = sourceRange.Cells(i, k).Value
    
34.                         matchCount = matchCount + 1
    
35.                     End If
    
36.                 End If
    
37.             Next k
    
38.         Next j
    
39.     Next i
    
40.    
    
41.     MsgBox "提取完成！"
    
42. End Sub
    
43. 
    

复制代码

ww87725244

=IFERROR(SMALL(IF(COUNTIF($B3:$U3,$B2:$U2)>0,$B2:$U2,""),COLUMN(A1)),"")

longwin

请看附件....

飞越一切

longwin 发表于 2024-8-28 18:01
请看附件....

大佬，非常感谢

ynzsvt

请测试结果

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.28
   
2.     With Sheets("Sheet1")
   
3.         r = .Cells(Rows.Count, 1).End(3).Row
   
4.         arr = .[a1].Resize(r, 21)
   
5.         ReDim brr(1 To r, 1 To 20)
   
6.         For i = 2 To UBound(arr)
   
7.             n = 0
   
8.             m = m + 1
   
9.             For j = 2 To UBound(arr, 2)
   
10.                 If arr(i, j) = arr(i - 1, j) Then
    
11.                     n = n + 1
    
12.                     brr(m, n) = arr(i, j)
    
13.                 End If
    
14.             Next
    
15.         Next
    
16.         .[w2].Resize(m, 20) = ""
    
17.         .[w2].Resize(m, 20) = brr
    
18.     End With
    
19. End Sub
    

复制代码