删除不符合要求组数据的问题

dfshm

附件 删除组数据附件.rar (167.84 KB, 下载次数: 8)

2024-4-5 21:44 上传

点击文件名下载附件

谢谢老师！

shiruiqiang

https://club.excelhome.net/thread-1689011-1-1.html

原理相同，循环step5，if cells(x,m)=cells(x+1,m)=cells(x+2,m)=cells(x+3,m), then copy

cnmlgb9998

PQ 一句代码！！！！！！！！！

cnmlgb9998

楼主，上一题，给你做了，都不表态的?????? 这里又变换了一题，做了，还不发红花？

dfshm

cnmlgb9998 发表于 2024-4-5 22:14
楼主，上一题，给你做了，都不表态的?????? 这里又变换了一题，做了，还不发红花？

一头雾水。找不到高级编辑器。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.5
   
2.     With Sheets("Sheet1")
   
3.         r = .Cells(Rows.Count, 1).End(3).Row
   
4.         arr = .[a1].Resize(r, 13)
   
5.     End With
   
6.     ReDim brr(1 To UBound(arr), 1 To 13)
   
7.     On Error Resume Next
   
8.     For i = 1 To UBound(arr) Step 5
   
9.         fft = 1
   
10.         For x = 1 To 3
    
11.             ft = IIf(arr(i, 13) = arr(i + x, 13), 1, 0)
    
12.             fft = fft * ft
    
13.         Next
    
14.         If fft = 1 Then
    
15.             For x = 1 To 5
    
16.                 m = m + 1
    
17.                 For j = 1 To UBound(arr, 2)
    
18.                     brr(m, j) = arr(i + x - 1, j)
    
19.                 Next
    
20.             Next
    
21.         End If
    
22.     Next
    
23.     With Sheets("Sheet2")
    
24.         .[a1:m10000] = ""
    
25.         .[a1].Resize(m, 13) = brr
    
26.     End With
    
27.     MsgBox "OK！"
    
28. End Sub
    

复制代码

512008404

参与一下！

lushang2018

1. Sub 测试()
   
2.     Dim i%, j%, k%, m%, arr, brr
   
3.     arr = Sheet2.Range("A1:M" & sheet1.Cells(Rows.Count, "A").End(xlUp).Row)
   
4.     ReDim brr(1 To 10000, 1 To UBound(arr, 2))
   
5.     For i = LBound(arr) To UBound(arr) Step 5
   
6.         If arr(i, 13) = arr(i + 1, 13) _
   
7.             And arr(i + 1, 13) = arr(i + 2, 13) _
   
8.             And arr(i + 2, 13) = arr(i + 3, 13) Then
   
9.             k = k + 1
   
10.             For j = 1 To 5
    
11.                 For m = 1 To UBound(arr, 2)
    
12.                     brr((k - 1) * 5 + j, m) = arr(i + j, m)
    
13.                 Next
    
14.             Next
    
15.         End If
    
16.     Next
    
17.     Sheet3.Range("A1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
18. End Sub
    

复制代码

lushang2018

试一试，试一试