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

 

[Rick Rothstein]

https://www.dropbox.com/s/vd4co9doegi2l5p/Mrexcel.xlsm?dl=0
my apologies for that

So, it looks like we should be looking at Sheet1 in the file you sent and I am assuming you want us to produce Column F from the values in Column E, is that correct? On that sheet, you show two columns after Column F labeled BOM and QTY... will those columns ever have values in them? If so, were they originally Columns F and G but moved over one column each to make room for what you show in Column F? If so, do we have to do that for you in code or will Column F be empty so that we can just dump the reworked values into it?

 

[dado6612]

So, it looks like we should be looking at Sheet1 in the file you sent and I am assuming you want us to produce Column F from the values in Column E, is that correct? On that sheet, you show two columns after Column F labeled BOM and QTY... will those columns ever have values in them? If so, were they originally Columns F and G but moved over one column each to make room for what you show in Column F? If so, do we have to do that for you in code or will Column F be empty so that we can just dump the reworked values into it?

Hi Rick, thanks for reply, if you look at Sheet Moved, that is exactly what I'm trying to recreate with a code in Sheet1. Data is taken from Master table
Column F for now serves as dump column
At the end columns G and H are irelevant for now and can be used for anything. At the very end there will be simple formula G=D3 filled down and h= count

 

[DanteAmor]

test with:

For i = fil To lr + 1

 

[Rick Rothstein]

Hi Rick, thanks for reply, if you look at Sheet Moved, that is exactly what I'm trying to recreate with a code in Sheet1. Data is taken from Master table

I am having trouble figuring out the relationship between the sheets. It does not look like the same numbers were used for each sheet, at least as far as I can tell.

 

[dado6612]

I am having trouble figuring out the relationship between the sheets. It does not look like the same numbers were used for each sheet, at least as far as I can tell.

Hi Rick,
They are the same numbers. If you pick any string of numbers in column E from sheet Moved and find it in Master table, you can notice that it will have same values in row (part number, order number)(note that those are 2 tables in 1, left are doors, right are cabs, where in table Moved door is listed as c4d and cab as c4c)
Only difference is that all of them strings in column E are handpicked and its hard to recreate with a code, thats why it might be diferent on Sheet1, but thats irrelevant as long as other data match.
I'm here for any further questions, hope I could explain myself.
Thank you

 

[dado6612]

test with:

For i = fil To lr + 1

Sorry I missed this. Will test it later.
I think you got what the problem is, and I guess this might solve it.
So your code when run in column F while referencing column E does the job, but new data it makes is not assignesd to values from columns A and D. That is inportant to stay together (as seen in Moved sheet)
Second problem I might have is with the concateif formula, it's coded formula and I have problems telling code to place it in D2, evaluate and filldown.
All of that is first big problem, second big problem will be taking care of filling column F as seen in Moved sheet (will most likely open a new thread for it).
Thanks for amazing work so far guys, huge progress from where I got stuck.

 

[DanteAmor]

(will most likely open a new thread for it).

The best thing will be to open a new thread, the explanation should be, "what I have" and "what I want to result." Do not complicate assuming formulas or code. I help you with the whole macro.

 

[dado6612]

The best thing will be to open a new thread, the explanation should be, "what I have" and "what I want to result." Do not complicate assuming formulas or code. I help you with the whole macro.

Okay will do, thanks for the big help

 

[dado6612]

Okay, this part all done, in case anyone wants to know, see, tryout, seems like this does the job

Function ConcatIf(ByVal compareRange As Range, ByVal xCriteria As Variant, Optional ByVal stringsRange As Range, _Optional Delimiter As String, Optional NoDuplicates As Boolean) As String
Dim i As Long, j As Long
With compareRange.Parent
Set compareRange = Application.Intersect(compareRange, Range(.UsedRange, .Range("a1")))
End With
If compareRange Is Nothing Then Exit Function
If stringsRange Is Nothing Then Set stringsRange = compareRange
Set stringsRange = compareRange.Offset(stringsRange.Row - compareRange.Row, _
stringsRange.Column - compareRange.Column)
For i = 1 To compareRange.Rows.Count
For j = 1 To compareRange.Columns.Count
If (Application.CountIf(compareRange.Cells(i, j), xCriteria) = 1) Then
If InStr(ConcatIf, Delimiter & CStr(stringsRange.Cells(i, j))) <> 0 Imp Not (NoDuplicates) Then
ConcatIf = ConcatIf & Delimiter & CStr(stringsRange.Cells(i, j))
End If
End If
Next j
Next i
ConcatIf = Mid(ConcatIf, Len(Delimiter) + 1)
End Function


Sub findandinsertandcopymax8()
'On Error GoTo handle
Dim delivery As Date, llr As Long, l As Long
    Dim rng As Range, week As String, lrm As Long
    Dim rnc As Range, rni As Range, rna As Range
Dim col As String, cad As String, lrq As Long
    Dim lr As Long, fil As Double, cuenta As Integer
    Dim i As Double, j As Double, k As Double, coln As Double
    Set rng = Application.InputBox("Select working range", "Obtain Range Object", Type:=8)
    'week = InputBox("Week")
Application.ScreenUpdating = False
Set rnc = rng.Columns(4)
Set rna = rng.Columns(7)
Set rni = rng.Columns(1)
Worksheets("Master").Select
Range("a1").Select
rnc.Select
    Selection.SpecialCells(xlCellTypeConstants, 23).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Range("D2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=True, Transpose:=False
Worksheets("Sheet1").Range("D:d").RemoveDuplicates Columns:=1, Header:=xlNo
lr = Worksheets("Sheet1").Cells(Cells.Rows.Count, "D").End(xlUp).Row
Range("C2", "C" & lr).Formula = "=""C4D""&$z$1"
Range("C2", "C" & lr).Copy
Range("a2").PasteSpecial Paste:=xlPasteValues
Range("C2", "C" & lr).ClearContents
Worksheets("Master").Select
rna.Select
    Selection.SpecialCells(xlCellTypeConstants, 23).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Range("D65536").End(xlUp).Offset(1).Select
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=True, Transpose:=False
Worksheets("Sheet1").Range("D:d").RemoveDuplicates Columns:=1, Header:=xlNo
llr = Worksheets("Sheet1").Cells(Cells.Rows.Count, "D").End(xlUp).Row
Range("C" & lr + 1, "C" & llr).Formula = "=""C4C""&$z$1"
Range("C" & lr + 1, "C" & llr).Copy
Range("a" & lr + 1).PasteSpecial Paste:=xlPasteValues
Range("C" & lr + 1, "C" & llr).ClearContents
On Error GoTo eval
Range("e2").Formula = "=IF(concatif(Master!e:e,D2,Master!B:B,"" "",TRUE)="""",concatif(Master!h:h,D2,Master!B:B,"" "",TRUE),concatif(Master!e:e,D2,Master!B:B,"" "",TRUE))"
eval:
Evaluate ("e2")
Range("e2:e" & llr).FillDown
Range("e2", "e" & llr).Select
Selection.Copy
Range("e2").Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.ScreenUpdating = True
Application.ScreenUpdating = False
col = "E"
    lrm = Range(col & Rows.Count).End(xlUp).Row
    fil = 2
    coln = Columns(col).Column
    k = fil
    cuenta = 0
    For i = fil To lrm
        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)
                Range("d" & k, "d" & Cells(Rows.Count, 4).End(xlUp).Row).Select
    Selection.Cut Destination:=Range("d" & k + 1, "d" & Cells(Rows.Count, 4).End(xlUp).Row + 1)
   Cells(k, coln - 1).value = Cells(k + 1, coln - 1).value
    Cells(k, coln - 4).value = Cells(k + 1, coln - 4).value
                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
lrq = Worksheets("Sheet1").Cells(Cells.Rows.Count, "f").End(xlUp).Row
Range("f2", "f" & lrq).Select
Selection.Copy
Range("e2").Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("f2", "f" & lrq).ClearContents
Range("g2").Formula = "=d2"
Evaluate ("g2")
Range("g2", "g" & lrq).FillDown
Range("g2", "g" & lrq).Select
Selection.Copy
Range("g2").Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("h2").Formula = "=LEN(e2)-LEN(SUBSTITUTE(e2,"" "",""""))+1"
Evaluate ("h2")
Range("h2", "h" & lrq).FillDown
Range("h2", "h" & lrq).Select
Selection.Copy
Range("h2").Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Worksheets("Sheet1").Range("B2", "B" & lrq) = InputBox("Due date")
Range("C2", "C" & lrq).value = "COMBILIFT"
Range("i2").Formula = "=COUNTIF($A$2:A2,A2)"
Evaluate ("i2")
Range("i2", "i" & lrq).FillDown
Range("i2", "i" & lrq).Select
Selection.Copy
Range("i2").Select
Selection.PasteSpecial Paste:=xlPasteValues
For l = 2 To lrq
        Range("a" & l) = Range("a" & l).Text & week & "-" & Range("i" & l).Text
    Next l
Range("i2", "i" & lrq).ClearContents
Cells.Select
    Cells.EntireColumn.AutoFit
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection.Font
        .Name = "Calibri"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Range("A1").Select
'handle: Exit Sub
Application.ScreenUpdating = True
'Worksheets("Master").Select
'Range("A1").Select
End Sub

Thank you all for huge help on this (specially DanteAmor). I'm on my way to attack one more problem. I guess I see you all soon