Loop then delete

[owen4512]

Hi all,

I have created the below macro that will check the dates in column 8 on sheet1. It will then copy the row and paste the data onto sheet2 if the date is less than or equal to cell "K1". The macro is working perfectly but i'm struggling to tell excel to delete the the row after it has been copied.

This is what i've done so far;

Sub Import_data()


a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Dim sh1 As Worksheet
Set sh1 = Worksheets("sheet1")
Dim sh2 As Worksheet
Set sh2 = Worksheets("sheet2")


For i = 2 To a


    If sh1.Cells(i, 8).Value <= sh2.Range("k1").Value Then
            sh1.Rows(i).Cut
            sh2.Activate
            b = sh2.Cells(Rows.Count, 1).End(xlUp).Row
            sh2.Cells(b + 1, 1).Select
            ActiveSheet.Paste
            sh1.Activate
        
    End If
    
Next


Application.CutCopyMode = False
sh1.Activate
ThisWorkbook.Worksheets("sheet1").Cells(1, 1).Select
sh2.Activate






End Sub

 

[dmt32]

Hi,

untested but try following:

Sub Import_data()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim CopyRange As Range
    Dim Lr As Long, i As Long
    
    Set sh1 = Worksheets("sheet1")
    Set sh2 = Worksheets("sheet2")
    
    Lr = sh1.Cells(sh1.Rows.Count, 1).End(xlUp).Row
    
    For i = 2 To Lr
        
        If sh1.Cells(i, 8).Value <= sh2.Range("k1").Value Then
            If CopyRange Is Nothing Then
                Set CopyRange = sh1.Cells(i, 1)
            Else
                Set CopyRange = Union(CopyRange, sh1.Cells(i, 1))
            End If
        End If
        
    Next
    
    If Not CopyRange Is Nothing Then
        With CopyRange.EntireRow
            .Copy sh2.Cells(sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Row + 1, 1)
            .Delete shift:=xlShiftUp
        End With
    End If
    
End Sub

Dave

 

[owen4512]

Hi Dave,

That seems to have done it.

Thanks

 

[dmt32]

Hi Dave,

That seems to have done it.

Thanks

most welcome - thanks for feedback

Dave