PDA

View Full Version : Search for repeated characters



Claire
08-15-2008, 08:53 AM
Hi,

Could someone please help me with the following problem I have written a few macros in the past but this one has got me stumped :banghead:
I need a macro which will search a spreadsheet and if a cell contains more than 4 of the same letter, the entire row will be cut and moved to a different sheet.
I also need one that will remove a row if a cell contains more than 20 characters.
Thank you for any help

RonMcK
08-15-2008, 09:00 AM
Can you post a workbook showing what we can expect on the source worksheet, a sample of your target worksheet with samples of the two types of moved data?

Thanks,

Claire
08-15-2008, 09:03 AM
Hi,

Thanks for your reply.

It is for name sorter for a survey so it would look something like this.

A B
1 John Smith
2 Andrew Jones
3 asdffffg hgjjhjhh
4 anananannananan sdfghjk


So rows 1 and 2 would be kept, 3 and 4 would be cut and moved to another sheet for review, there may be other fields such as address so it would need to search several columns.

Thanks

RonMcK
08-15-2008, 09:44 AM
Claire,

Thanks, I'll work on this tonight.

mdmackillop
08-15-2008, 12:59 PM
Option Explicit
Sub Test()
Dim txt As String
Dim cel As Range
Dim Ln As Long
Dim i As Long
Dim Tgt As Range
Dim LR As Long
Dim r As Long
Dim x As Range

'Find end of range
LR = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
'Work from bottom of range
For i = LR To 1 Step -1
'Only look at constants: Is this correct?
On Error Resume Next
Set x = Intersect(Rows(i), ActiveSheet.UsedRange).SpecialCells(xlCellTypeConstants)
If Not x Is Nothing Then
For Each cel In x
'Convert to capitals so A = a
txt = UCase(cel)
'Delete long text: What about spaces?
If Len(txt) > 20 Then
Rows(i).Delete
Exit For
Else
Do
'Get length
Ln = Len(txt)
'Remove all cases of first character
txt = Application.Substitute(txt, Left(txt, 1), "")
'Check new length; if diff >4 then more than 4 repeated characters
If Ln - Len(txt) > 4 Then
r = r + 1
'Move row to Sheet2
Rows(i).Cut Sheets(2).Cells(r, 1)
Exit For
End If
'Test next letter
Loop Until Ln < 5
End If
Next cel
End If
Set x = Nothing
Next i
End Sub

Claire
08-18-2008, 02:35 AM
That is great mdmackillop, thank you for your help!!

Claire
08-18-2008, 08:13 AM
Hi mdmackillop,

You put a note in the code regarding the length of a word to be removed incluiding spaces.
How would I ammend the code so that it only removed a continous string of characters, ie "reallylongstreetname" was removed but "really long street name" was not?

Many thanks

mdmackillop
08-18-2008, 08:44 AM
Use the Substitute line to count the spaces, Divide text length by spaces to get an average. Carry out an action based on the result.

Claire
08-20-2008, 02:25 AM
Hi,

Thank you for your advice

I have tried the following
(Entered Dim spcs AS long)

spcs = Len(Substitute(txt, " ", ""))
If spcs / Len(txt) > 10 Then

Instead of

If Len(txt) >20 Then



but when I run it I get a "Sub or function not defined" compile error.
And the substitue part is hi lighted, but surely that must be ok as it is used later in the code?


Thank you for any help :bow: