If found more than x characters in a cell, copy row, insert below

[dado6612]

Hi all
Trying to do a bit of code where it would go thru the column and if it finds more than 7 spaces in a cell, it would copy that row and insert it under it
I've tried something like this but doesn't work
llr is last row

Range("e3", "e" & lllr).SelectFor Each c In Selection
c.Activate
if
ActiveCell.FormulaR1C1 = len(r3c5)-len(substitute(r3c5," "),""))
Case Is < 8
GoTo bla
Case Is > 7
ActiveCell.EntireRow.Copy
    Selection.Insert Shift:=xlDown
bla:
Next c

Bonus to this would be if possible to delete everything, including, after the 8th space, and in row under to remove everything, including, prior the 8th space

Ex, If it's a sentence like this in a cell then do this.

If it's a sentence like this in a
cell then do this.

Any help? Thanks

 

[DanteAmor]

Check this:

Sub found_more_than_x_characters()
    Application.ScreenUpdating = False
    lr = Range("E" & Rows.Count).End(xlUp).Row  'last row
    For i = lr To 3 Step -1
        val1 = Cells(i, "E").Value
        val2 = WorksheetFunction.Substitute(val1, " ", "")
        cuenta = Len(val1) - Len(val2)
        If cuenta > 7 Then
            Rows(i).Copy
            Rows(i + 1).Insert Shift:=xlDown
            Cells(i + 1, "E").Value = val2
        End If
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "End"
End Sub

if it is not what you need, you can give an example of what you have and what you expect from the result.

Regards

 

[dado6612]

Check this:

Sub found_more_than_x_characters()
    Application.ScreenUpdating = False
    lr = Range("E" & Rows.Count).End(xlUp).Row  'last row
    For i = lr To 3 Step -1
        val1 = Cells(i, "E").Value
        val2 = WorksheetFunction.Substitute(val1, " ", "")
        cuenta = Len(val1) - Len(val2)
        If cuenta > 7 Then
            Rows(i).Copy
            Rows(i + 1).Insert Shift:=xlDown
            Cells(i + 1, "E").Value = val2
        End If
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "End"
End Sub

if it is not what you need, you can give an example of what you have and what you expect from the result.

Regards

Thanks for your effort, but code does nothing for me. I see no difference after code has run. Tho reading it as it is seems it would fit perfectly.

What I have in column D is series of numbers in cells
ex. 42920 42957 43044 43045 43046 43087 SPARE1 SPARE2 40925 40926 43183 43211 43212
so when something like this is found it, it needs to be split in 2 rows, 8 numbers per row
42920 42957 43044 43045 43046 43087 SPARE1 SPARE2
40925 40926 43183 43211 43212
Maybe that series of numbers stored as text might be a problem?
while everything else in rest of columns can be simply copied down
I have a code which does some job, at the end of it I've put call sub command for your code

Thanks

 

[dado6612]

Check this:

Sub found_more_than_x_characters()
    Application.ScreenUpdating = False
    lr = Range("E" & Rows.Count).End(xlUp).Row  'last row
    For i = lr To 3 Step -1
        val1 = Cells(i, "E").Value
        val2 = WorksheetFunction.Substitute(val1, " ", "")
        cuenta = Len(val1) - Len(val2)
        If cuenta > 7 Then
            Rows(i).Copy
            Rows(i + 1).Insert Shift:=xlDown
            Cells(i + 1, "E").Value = val2
        End If
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "End"
End Sub

if it is not what you need, you can give an example of what you have and what you expect from the result.

Regards

Alright, after some adapting, it does half the work, in copied row it copies everything but without spaces, I need it as this
ex. 42920 42957 43044 43045 43046 43087 SPARE1 SPARE2 40925 40926 43183 43211 43212
so when something like this is found it, it needs to be split in 2 rows, 8 strings per row
42920 42957 43044 43045 43046 43087 SPARE1 SPARE2
40925 40926 43183 43211 43212

Thanks

 

[dado6612]

I'm back again
Seems like this formula might do the trick, how to adapt it to your code?

=RIGHT(E1,LEN(E1)-FIND(" ",E1,FIND(" ",E1,FIND(" ",E1,FIND(" ",E1,FIND(" ",E1,FIND(" ",E1,FIND(" ",E1,FIND(" ",E1)+1)+1)+1)+1)+1)+1)+1)+1)

and then row before it would have basically the same I guess just with Left function

Thanks

 

[DanteAmor]

I do not understand you, you asked for this: "if it finds more than 7 spaces in a cell, it would copy that row and insert it under it".
after this: "it needs to be split in 2 rows, 8 strings per row".}
and now this: "=RIGHT(E1,LEN(E1)-FIND(" ",E1,FIND(" ",E1,FIND(" ",E1,FIND(" ",E1,FIND(" ",E1,FIND(" ",E1,FIND(" ",E1,FIND(" ",E1)+1)+1)+1)+1)+1)+1)+1)+1)"


the formula does not split a line in two.

I 'm going to take the example to do the macro

What I have in column D is series of numbers in cells
ex. 42920 42957 43044 43045 43046 43087 SPARE1 SPARE2 40925 40926 43183 43211 43212
so when something like this is found it, it needs to be split in 2 rows, 8 numbers per row
42920 42957 43044 43045 43046 43087 SPARE1 SPARE2
40925 40926 43183 43211 43212

then try the following:

Sub found_more_than_x_characters()
    Application.ScreenUpdating = False
    Dim col As String, cad As String
    Dim lr As Double, fil As Double, cuenta As Integer
    Dim i As Double, j As Double, k As Double, coln As Double
    col = "E"                                   'column with numbers
    lr = Range(col & Rows.Count).End(xlUp).Row  'last row
    fil = 3                                     'initial row with numbers
    '
    coln = Columns(col).Column
    k = fil
    cuenta = 0
    For i = fil To lr
        numbers = Split(Cells(i, col).Value, " ")
        For j = LBound(numbers) To UBound(numbers)
            If cuenta > 7 Then
                Cells(k, coln + 1).Value = Mid(cad, 2)
                k = k + 1
                cad = ""
                cuenta = 0
            End If
            cad = cad & " " & numbers(j)
            cuenta = cuenta + 1
        Next
        If cad <> "" Then
            Cells(k, coln + 1).Value = Mid(cad, 2)
            k = k + 1
            cad = ""
            cuenta = 0
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "End"
End Sub

if your numbers are in column E then the macro will put the rows in column F.
For example, if you have this in a cell E3: "42920 42957 43044 43045 43046 43087 SPARE1 SPARE2 12345 12346 12347 12348 12349 12350 12351 12352 12353 12354 12355 SPARE1 SPARE2 12356 12357 12358 12359 12360", the macro will put the result in 4 rows


42920 42957 43044 43045 43046 43087 SPARE1 SPARE2
12345 12346 12347 12348 12349 12350 12351 12352
12353 12354 12355 SPARE1 SPARE2 12356 12357 12358
12359 12360

Regards

 

[dado6612]

then try the following:

Sub found_more_than_x_characters()
    Application.ScreenUpdating = False
    Dim col As String, cad As String
    Dim lr As Double, fil As Double, cuenta As Integer
    Dim i As Double, j As Double, k As Double, coln As Double
    col = "E"                                   'column with numbers
    lr = Range(col & Rows.Count).End(xlUp).Row  'last row
    fil = 3                                     'initial row with numbers
    '
    coln = Columns(col).Column
    k = fil
    cuenta = 0
    For i = fil To lr
        numbers = Split(Cells(i, col).Value, " ")
        For j = LBound(numbers) To UBound(numbers)
            If cuenta > 7 Then
                Cells(k, coln + 1).Value = Mid(cad, 2)
                k = k + 1
                cad = ""
                cuenta = 0
            End If
            cad = cad & " " & numbers(j)
            cuenta = cuenta + 1
        Next
        If cad <> "" Then
            Cells(k, coln + 1).Value = Mid(cad, 2)
            k = k + 1
            cad = ""
            cuenta = 0
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "End"
End Sub

Regards

Sorry if I'm that bad at explaining what I need
That does half the job. Is it possible to with what your code does to do 2 small changes
1. Insert as many new rows code made under the reference cell
2. Copy data from other columns (A:D) of reference row

As in your example:

Test1	Test1	Test1	Test1	42920 42957 43044 43045 43046 43087 SPARE1 SPARE2 12345 12346 12347 12348 12349 12350 12351 12352 12353 12354 12355 SPARE1 SPARE2 12356 12357 12358 12359 12360
Test2	Test2	Test2	Test2	12345
Test3	Test3	Test3	Test3	53452

<tbody>
</tbody>

It becomes

Test1	Test1	Test1	Test1	42920 42957 43044 43045 43046 43087 SPARE1 SPARE2
Test1	Test1	Test1	Test1	12345 12346 12347 12348 12349 12350 12351 12352
Test1	Test1	Test1	Test1	12353 12354 12355 SPARE1 SPARE2 12356 12357 12358
Test1	Test1	Test1	Test1	12359 12360
Test2	Test2	Test2	Test2	12345
Test3	Test3	Test3	Test3	53452

<tbody>
</tbody>

The cell in "E" column with multiple strings can occur anywhere so it would have to be flexible to insert a row, copy data, split strings as your code does.
Hope it makes more sense now
Thanks

 

[DanteAmor]

But in your example you are not inserting a new line, nor are you doing a split data, you are only copying the texts in a following line. I still do not understand.
Could You upload a file with real data, in sheet 1 you put the current data and in sheet 2 you put the expected result?

 

[dado6612]

But in your example you are not inserting a new line, nor are you doing a split data, you are only copying the texts in a following line. I still do not understand.
Could You upload a file with real data, in sheet 1 you put the current data and in sheet 2 you put the expected result?

How to upload it on here?

 

[DanteAmor]

in the cloud, it can be dropbox, then you put the link or send me an email to :