求助按条件剪切合符条件的数据行

Justin-2016

求助按条件剪切合符条件的数据行.zip (7.57 KB, 下载次数: 6)

2024-3-15 20:09 上传

点击文件名下载附件

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, i&, iRow&, Rng As Range
   
    With Sheets(1).[A1].CurrentRegion
        ar = .Value
        For i = 2 To UBound(ar)
            If Len(ar(i, 2)) Then
                If Rng Is Nothing Then
                    Set Rng = .Rows(i)
                Else
                    Set Rng = Union(Rng, .Rows(i))
                End If
            End If
        Next i
    End With
    If Not Rng Is Nothing Then
        iRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
        Rng.Copy Cells(iRow, 1)
    Else
        MsgBox "未找到数据"
    End If
    Beep
End Sub

gwjkkkkk

请参考。。。

yanglinzi

1. Sub test()
   
2. Dim arr, i, j, r
   
3. arr = Sheet1.UsedRange
   
4. For i = 2 To UBound(arr)
   
5.     If Len(arr(i, 2)) > 0 Then
   
6.         Set Rng = Sheet1.Cells(i, 1).Resize(1, UBound(arr, 2))
   
7.         Set rngs = Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
   
8.         Rng.Copy rngs
   
9.         Rng.ClearContents
   
10.     End If
    
11. Next
    
12. End Sub
    

复制代码

yanglinzi

请测试。。

Justin-2016

gwjkkkkk 发表于 2024-3-15 21:19
Option Explicit
Sub TEST1()
    Dim ar, i&, iRow&, Rng As Range

感谢帮助！代码会重复添加数据，谢谢！

Justin-2016

yanglinzi 发表于 2024-3-15 21:54

表2目的达到了，表1数据到表2后出现的空行没有删除，请大神再优化下代码，谢谢！

ykcbf1100

干么要剪切呢，直接用数组不就完了嘛。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.16
   
2.     With Sheets("Sheet1")
   
3.         r = .Cells(Rows.Count, 1).End(3).Row
   
4.         arr = .Range("a6:d" & r)
   
5.         .Range("a6:d" & r) = ""
   
6.     End With
   
7.     With Sheets("Sheet2")
   
8.         r = .Cells(Rows.Count, 1).End(3).Row
   
9.         .Cells(r + 1, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
   
10.     End With
    
11.     MsgBox "OK！"
    
12. End Sub
    
13. 
    

复制代码

yanglinzi

Justin-2016 发表于 2024-3-16 08:58
表2目的达到了，表1数据到表2后出现的空行没有删除，请大神再优化下代码，谢谢！

吧rng.clearcontents换成rng.delete就可以了