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

D

dado6612

Well-known Member
Joined
Dec 4, 2009
Messages
591
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
Code: 
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
 

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
Sort by date Sort by votes
Check this:

Code: 
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
 
Upvote 0
DanteAmor said:
Check this:

Code: 
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
Click to expand...

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
 
Last edited:
Upvote 0
DanteAmor said:
Check this:

Code: 
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
Click to expand...

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
 
Upvote 0
I'm back again
Seems like this formula might do the trick, how to adapt it to your code?

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
 
Upvote 0
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
Click to expand...

then try the following:

Code: 
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
 
Upvote 0
DanteAmor said:
then try the following:

Code: 
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
Click to expand...
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:
[TABLE="class: grid, width: 50, align: center"]
<tbody>[TR]
[TD]Test1[/TD]
[TD]Test1[/TD]
[TD]Test1[/TD]
[TD]Test1[/TD]
[TD]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[/TD]
[/TR]
[TR]
[TD]Test2[/TD]
[TD]Test2[/TD]
[TD]Test2[/TD]
[TD]Test2[/TD]
[TD]12345[/TD]
[/TR]
[TR]
[TD]Test3[/TD]
[TD]Test3[/TD]
[TD]Test3[/TD]
[TD]Test3[/TD]
[TD]53452[/TD]
[/TR]
</tbody>[/TABLE]

It becomes
[TABLE="class: grid, width: 50, align: center"]
<tbody>[TR]
[TD]Test1[/TD]
[TD]Test1[/TD]
[TD]Test1[/TD]
[TD]Test1[/TD]
[TD]42920 42957 43044 43045 43046 43087 SPARE1 SPARE2[/TD]
[/TR]
[TR]
[TD]Test1[/TD]
[TD]Test1[/TD]
[TD]Test1[/TD]
[TD]Test1[/TD]
[TD]12345 12346 12347 12348 12349 12350 12351 12352[/TD]
[/TR]
[TR]
[TD]Test1[/TD]
[TD]Test1[/TD]
[TD]Test1[/TD]
[TD]Test1[/TD]
[TD]12353 12354 12355 SPARE1 SPARE2 12356 12357 12358[/TD]
[/TR]
[TR]
[TD]Test1[/TD]
[TD]Test1[/TD]
[TD]Test1[/TD]
[TD]Test1[/TD]
[TD]12359 12360[/TD]
[/TR]
[TR]
[TD]Test2[/TD]
[TD]Test2[/TD]
[TD]Test2[/TD]
[TD]Test2
[/TD]
[TD]12345[/TD]
[/TR]
[TR]
[TD]Test3[/TD]
[TD]Test3[/TD]
[TD]Test3[/TD]
[TD]Test3[/TD]
[TD]53452[/TD]
[/TR]
</tbody>[/TABLE]

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
 
Upvote 0
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?
 
Upvote 0
DanteAmor said:
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?
Click to expand...

How to upload it on here?
 
Upvote 0
in the cloud, it can be dropbox, then you put the link or send me an email to :
 
Last edited by a moderator:
Upvote 0
You must log in or register to reply here.

Similar threads

U
  • Question Question
When a value is detected in a cell, a VBA code or function will insert a new row with specific values and functions already in each cell
Replies
0
Views
315
ubergreen
U
A
  • Solved
Inserting new rows based on cell value, and copying data to the new rows
Replies
5
Views
2K
Andrew87
A
A
  • Solved
Calendar form cancel button passing data to worksheet
Replies
7
Views
1K
AndyEd
A
P
  • Solved
VBA remember original row number when cutting and inserting
Replies
3
Views
830
johnnyL
J
G
  • Solved
Copy a cell value (x) from one Workbook (A) to Workbook (B) if finds a lookup cell value (y) from Workbook (A)
2
Replies
15
Views
1K
GijoeBlack
G

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top