need help with a complex formula

Copper Contributor

Hi all...need some help here.  trying to automate what I'm currently doing manually.  Ideally, every 4th row of my data set would have only 2 letters, as shown below:

 

JD

John Doe

Consultant

Company X

JS

John Smith

Engineer

Company Y

 

However, in many cases this order is missing.  I want to be able to return the contents of every 4th cell to validate that it has 2 characters but I can't do that if the pattern is not the same.  Where I find that every 4th cell is NOT a count of 2, I manually go in, insert a row, and put in the two initials of the person's name.  This takes forever.  For example...in the above, if 'JS' was not there, the 4th cell would return 'John Smith', instead of the desired 'JS'

 

What I WANT to do is where it is identified that the 4th cell down does NOT have a count of 2, insert a row above the 4th cell, and take the first letter of the persons first name and last  name and enter it.

 

Example:

JD

John Doe

Consultant

Company X

John Smith

Engineer

Company Y

 

what would happen here is that the macro would insert a row above 'john smith' and in the cell above it it would show 'JS'.

 

I have the first part which is =OFFSET($A$1,(ROW()-1)*4,0).  I don't know how to do the row insert and then the parsing of first letter of first name and last name.

 

Thanks!

 

2 Replies

@cuseman03 

Run this macro:

Sub FixIt()
    Const c = 1 ' column A
    Dim r As Long
    Dim s As String
    Dim w
    Application.ScreenUpdating = False
    r = 1 ' starting at row 1
    Do
        s = Cells(r, c).Value
        If Len(s) > 2 Then
            Cells(r, c).EntireRow.Insert
            w = Split(s)
            If UBound(w) > 0 Then
                Cells(r, c).Value = Left(w(0), 1) & Left(w(1), 1)
            Else
                MsgBox "'" & s & "' does not contain a space!", vbExclamation
                Cells(r, c).Value = Left(s, 2)
            End If
        End If
        r = r + 4
    Loop Until Cells(r, c).Value = ""
    Application.ScreenUpdating = True
End Sub

@Hans Vogelaar **bleep**, you're good.  I ran it and didn't see anything happen so to test it I deleted a row to recreate my pattern break and it worked perfectly, inserting a new row with the initials.  Thanks!