Macro to delete cell and adjacent cell if criteria not met?

[stevenash1367]

I will give a watered down version:

Need to see if cells in column Q is equal to "ABC" or "EFG"
If not then would like to delete the cell in column Q and adjacent cell in column R and shift cell leftwards ( so cells in column S would become Q and T would become R).

So lets say Q501 is not equal to ABC or EFG then delete Q501 and R501 and move S501 and T501 over to Q501 and R501.

Thanks for your help

 

[John Davis]

If Range("Q" & i).Value = "ABC" Or Range("Q" & i).Value = "EFG" Then Range("Q" & i).Value = Range("Q" & i).Value Else Range(Range("Q" & i), Range("R" & i)).Value = Range(Range("S" & i), Range("T" & i)).Value Range(Range("S" & i), Range("T" & i)).Delete shift:=xlToLeft

I was debugging and got an error when I am at this step.
</pre>

Steve:

You need to use code tags when posting code, everything in this post is jumbled together, and I can't tell which line is which?

to post using code before you add code place this at the beginning [ code ] and at the end [ /code ]

 

[stevenash1367]

[ code ]
If Range("Q" & i).Value = "ABC" Or Range("Q" & i).Value = "EFG" Then

Range("Q" & i).Value = Range("Q" & i).Value

Else

Range(Range("Q" & i), Range("R" & i)).Value = Range(Range("S" & i), Range("T" & i)).Value

Range(Range("S" & i), Range("T" & i)).Delete shift:=xlToLeft
[ /code ]

 

[stevenash1367]

Range(Range("Q" & i), Range("T" & i)) = Trim(Range(Range("Q" & i), Range("T" & i)))

When skipping over this step the message pops up

 

[chirp]

i like doing these sorts of things, try this out, it should be fairly fast, not sure how much data you are looking at

Option Explicit
Option Base 1


Const COLLET As Long = 17

Sub del_Adjacent()

Dim lRow As Long, i As Long
Dim tCell As Range, srchRng As Range, delRng As Range
Dim tArr, tVar
Dim tStr As String

'simple error handle
On Error GoTo exitSub

With ActiveSheet 'this is redundant but can be changed for better control/multisheet loops
    
    'gets the used range of the column in a roundabout way
    Set tCell = .Cells(.Rows.Count, COLLET)
    
    'this returns the last row in specified column
    If tCell.Formula = vbNullString Then
        lRow = tCell.End(xlUp).Row
    Else
        lRow = .Rows.Count
    End If
    
    'sets the range to search
    Set srchRng = .Range(.Cells(1, COLLET), .Cells(lRow, COLLET))
    
    'defines an array, should speed things up
    If lRow = 1 Then
        tArr = Array(srchRng)
    Else
        tArr = srchRng
    End If

    
    'loops through the array checking values and adding any valid ranges to the delete range
    For Each tVar In tArr
        tStr = CStr(tVar)
        If tStr <> "EEG" And tStr <> "ABC" Then
                If delRng Is Nothing Then
                    Set delRng = .Cells(i + 1, COLLET).Resize(1, 2)
                Else
                    Set delRng = Union(delRng, .Cells(i + 1, COLLET).Resize(1, 2))
                End If
        End If
        
        i = i + 1
    Next
    
    If Not delRng Is Nothing Then delRng.Delete xlToLeft
End With

exitSub:
If Err.Number <> 0 Then
'some message here
End If
End Sub

 

[John Davis]

Range(Range("Q" & i), Range("T" & i)) = Trim(Range(Range("Q" & i), Range("T" & i)))

When skipping over this step the message pops up

Comment out that line. I commented it out and I got it too work partially? But I'm still investigating.

 

[John Davis]

Range(Range("Q" & i), Range("T" & i)) = Trim(Range(Range("Q" & i), Range("T" & i)))

When skipping over this step the message pops up

Try it now:

Sub stevenash1367()

Dim i As Long

Dim lr As Long

lr = Cells(Rows.Count, 1).End(xlUp).Row

For i = lr To 2 Step -1

    If Range("Q" & i).Value = "ABC" Then
    
        Range("Q" & i).Value = Range("Q" & i).Value
        
    ElseIf Range("Q" & i).Value = "EFG" Then
    
         Range("Q" & i).Value = Range("Q" & i).Value

        
    Else
    
        Range(Range("Q" & i), Range("R" & i)).Value = Range(Range("S" & i), Range("T" & i)).Value
        
        Range(Range("S" & i), Range("T" & i)).Delete shift:=xlToLeft
    
        
    End If
    
Next i

'

End Sub

 

[stevenash1367]

John, chirp,

Thank you both. Both of the formulas works to perfection

Now I will go back to practicing my basketball skills, if i can only get someone as good as you guys with excel

 

[chirp]

I am not trying to be rude, and am probably just confused, but what are you trying to do here?

why are you finding the last row for column a?

why are you doing this:

Range("Q" & i).Value = Range("Q" & i).Value

and why would you copy the data in s and t over, why not just delete Q and R?

 

[John Davis]

You are very right, and make some valid points, now that I take a second sober look at things. I just got caught up bouncing back and forth between work and mrexcel when the boss is not looking.

 

[stevenash1367]

Chirp,
If I want to also do this for columns S and U, how would I manipulate your macro?
I believe you are using Collet = 17 for Q
So Collet = 19 and Collet = 21.
I tried adding "And" in the first statement and it does not work