macro which delets cell if the cell above has the same keyword

[andrei]

Example :

A1 : mother and father
A2 : mother
A3 : empty cell
A4 : uncle and nice
A5 : uncle
A6 : uncle and
A7 : empty cell

I need the macro to analyse the column and to put the result in a different
column . The result should be :

B1 : mother and father
B2 : uncle and nice

So , "mother" is found in A1 . If same keyword is found in the next 1 to n
cells , it delets content from those cells . The content from A1 is put in
B1 . There is always at least an empty cell (like A3 in my example) between
cells containing the text to be analysed . The macro moves to A4 where it
finds "uncle and nice" . The cells A5 and A6 contain at least one word that
is in A4 cell , so they are deleted . The content from A4 is put in B2 cell

 

[Per Jessen]

Hi

Try if this is what you need:

Sub aaa()
Dim FirstRow As Long
Dim LastRow As Long
Dim KeyLen As Long
Dim DestCell As Range

Set DestCell = Range("B1")
LastRow = Range("A" & Rows.Count).End(xlUp).Row
FirstRow = 1
KeyLen = WorksheetFunction.Find(" ", Range("A1")) - 1
KeyWord = Left(Range("A1"), KeyLen)
DestCell = Range("A1").Value
Set DestCell = DestCell.Offset(1, 0)
For r = FirstRow + 1 To LastRow
If Left(Range("A" & r), KeyLen) = KeyWord Then
Range("A" & r) = ""
ElseIf Range("A" & r) <> "" Then
DestCell = Range("A" & r).Value
Set DestCell = DestCell.Offset(1, 0)
KeyLen = WorksheetFunction.Find(" ", Range("A" & r)) - 1
KeyWord = Left(Range("A" & r), KeyLen)
End If
Next
End Sub

Regards,
Per

 

[andrei]

Thanks , it works !

Hi

Try if this is what you need:

Sub aaa()
Dim FirstRow As Long
Dim LastRow As Long
Dim KeyLen As Long
Dim DestCell As Range

Set DestCell = Range("B1")
LastRow = Range("A" & Rows.Count).End(xlUp).Row
FirstRow = 1
KeyLen = WorksheetFunction.Find(" ", Range("A1")) - 1
KeyWord = Left(Range("A1"), KeyLen)
DestCell = Range("A1").Value
Set DestCell = DestCell.Offset(1, 0)
For r = FirstRow + 1 To LastRow
If Left(Range("A" & r), KeyLen) = KeyWord Then
Range("A" & r) = ""
ElseIf Range("A" & r) <> "" Then
DestCell = Range("A" & r).Value
Set DestCell = DestCell.Offset(1, 0)
KeyLen = WorksheetFunction.Find(" ", Range("A" & r)) - 1
KeyWord = Left(Range("A" & r), KeyLen)
End If
Next
End Sub

Regards,
Per