VBA only delete rows with values in column A

[ShadowLady17]

I have a macro that I copied from somewhere which sorts the data input from the import sheet to the sorted data sheet - to only copy new data, paste into a separate worksheet, and then delete those lines from the import sheet. However, I'd ideally like it to only delete rows where there is some sort of data in column A, so for rows where column A is blank, don't delete the rows. Is there any way to incorporate this into the existing macro below?

Sub London_Copy_New_Data()

'Copy all new rows from one worksheet to another.

Dim importSheet, destinationSheet As Worksheet
Dim importLastRow, importColumnCheck, destinationColumnCheck, _
importStartRow, destinationStartRow, curRow, destinationLastRow As Integer
Dim dataToCheck As Variant
Dim rng, rDel As Range


' ------------------------------------------------------------------- '
' ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| '
'           Change this section to work for your workbook.
' ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| '
' ------------------------------------------------------------------- '
'Set the worksheets
Set importSheet = Sheets("London Import") 'worksheet to copy data from
Set destinationSheet = Sheets("London Sorted Data") 'worksheet to paste new data

'Import data column to check
importColumnCheck = 18
'Destination data column to check
destinationColumnCheck = 18

'Start row on import sheet
importStartRow = 2
'Start row on destination sheet
destinationStartRow = 2
' ------------------------------------------------------------------- '
' ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| '
' ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| '
' ------------------------------------------------------------------- '


'Get last row from import worksheet
importLastRow = importSheet.Cells(Rows.Count, importColumnCheck).End(xlUp).Row

'Loop through range
For curRow = importStartRow To importLastRow

    'Get data to check
    dataToCheck = importSheet.Cells(curRow, importColumnCheck).Value

    'Get last row from destination sheet
    destinationLastRow = destinationSheet.Cells(Rows.Count, importColumnCheck).End(xlUp).Row

    'Check for duplicate
    With destinationSheet.Range(destinationSheet.Cells(destinationStartRow, destinationColumnCheck), destinationSheet.Cells(destinationLastRow, destinationColumnCheck))
        Set rng = .Find(What:=dataToCheck, _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)

        If Not rng Is Nothing Then
            'Record already exists

            'mark rows for deletion
            If Not rDel Is Nothing Then
                Set rDel = Union(Range("A" & curRow), rDel)
            Else
                Set rDel = Range("A" & curRow)
            End If

        Else
            'New record, so copy it over
            importSheet.Range("A" & curRow).EntireRow.Copy destinationSheet.Range("A" & destinationLastRow + 1)

            'mark rows for deletion
            If Not rDel Is Nothing Then
                Set rDel = Union(Range("A" & curRow), rDel)
            Else
                Set rDel = Range("A" & curRow)
            End If

        End If

    End With

Next curRow

'Delete rows that need to be deleted
'Un-comment the next line of code if you want to delete copied rows.
rDel.EntireRow.Delete

End Sub

 

[Flaiban]

Try this code ShadowLady...

Sub SpecialDelete()
    Dim i As Long
    For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
        If Cells(i, 1).Value2 = "" Then
            Rows(i).Delete
        End If
    Next i
End Sub

 

[ShadowLady17]

Try this code ShadowLady...

Sub SpecialDelete()
    Dim i As Long
    For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
        If Cells(i, 1).Value2 = "" Then
            Rows(i).Delete
        End If
    Next i
End Sub

How does this fit into the existing macro?

 

[Flaiban]

Now...everything will be alright

Sub ShadowLady17()

Dim rngPending As Range
Dim lngCounter As Long
Dim rngDelete As Range
Dim dataToCheck As Variant
Dim rng As Range

With Worksheets("London Import")
  Set rngCheck = .Range("A1:A" & .UsedRange.Rows.Count)
  .UsedRange.RemoveDuplicates Columns:=Array(1, 1), Header:=xlYes
End With
'On Error Resume Next
Application.ScreenUpdating = False
For lngCounter = 2 To rngCheck.Count
  If CStr(rngCheck(lngCounter).Value) <> "" Then
        rngCheck(lngCounter).EntireRow.Copy Destination:=Worksheets("London Sorted Data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    If rngDelete Is Nothing Then
      Set rngDelete = rngCheck(lngCounter)
    Else
      Set rngDelete = Union(rngDelete, rngCheck(lngCounter))
    End If
  End If

Next lngCounter

If Not rngDelete Is Nothing Then
  rngDelete.EntireRow.Delete
End If

Set rngDelete = Nothing
Set rngCheck = Nothing

Application.ScreenUpdating = True
End Sub

 

[kevin9999]

Another option for you.

Sub ShadowLady17()

    'Set range variables
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("London Import")
    Set ws2 = Worksheets("London Sorted Data")
    Dim LRow As Long, i As Long, Arr
    LRow = ws2.Cells(Rows.Count, 18).End(xlUp).Row + 1
    
    'Ceate array of values to exclude from copy & delete
    Dim d As Object, c As Range, tmp As String
    Set d = CreateObject("scripting.dictionary")
    Arr = Application.Transpose(ws1.Range("R2", ws1.Cells(Rows.Count, "R").End(xlUp)))
    
    For i = 1 To UBound(Arr, 1)
        d(Arr(i)) = 1
    Next i
    
    For Each c In ws2.Range("R2", ws2.Cells(Rows.Count, "R").End(xlUp))
        tmp = c.Value
        If d.exists(tmp) Then d.Remove (tmp)    '<< remove the exclusions from the dictionary
    Next c
    
    'Apply the filter & copy/delete
    With ws1.Range("A1").CurrentRegion
        .AutoFilter 18, Array(d.keys), 7
        .Offset(1).Resize(.Rows.Count - 1).Copy ws2.Range("A" & LRow)
        .AutoFilter 1, "<>"
        .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        .AutoFilter
    End With

End Sub

 

[kevin9999]

Error trap included if no new records found to copy/delete.

Option Explicit
Sub ShadowLady17_2()

    'Set range variables
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("London Import")
    Set ws2 = Worksheets("London Sorted Data")
    Dim LRow As Long, i As Long, Arr
    LRow = ws2.Cells(Rows.Count, 18).End(xlUp).Row + 1
    
    'Create array of values to include/exclude from copy & delete
    Dim d As Object, c As Range, tmp As String
    Set d = CreateObject("scripting.dictionary")
    Arr = Application.Transpose(ws1.Range("R2", ws1.Cells(Rows.Count, "R").End(xlUp)))
    
    For i = 1 To UBound(Arr, 1)
        d(Arr(i)) = 1
    Next i
    
    For Each c In ws2.Range("R2", ws2.Cells(Rows.Count, "R").End(xlUp))
        tmp = c.Value
        If d.exists(tmp) Then d.Remove (tmp)    '<< remove the exclusions from the dictionary
    Next c
    
    'Apply the filter & copy/delete
    If d.Count > 0 Then
        With ws1.Range("A1").CurrentRegion
            .AutoFilter 18, Array(d.keys), 7
            .Offset(1).Resize(.Rows.Count - 1).Copy ws2.Range("A" & LRow)
            .AutoFilter 1, "<>"
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
            .AutoFilter
        End With
    Else
        MsgBox "No new records found"
    End If

End Sub