how to specify only if 3 characters or less

[Guest]

I download a report that has a column heading "Name" and is in column D. The
name is last name then a comma then a space then the first name, for example
SMITH, FRED.

I would like to write a macro that would generate a report to pull only the
last names with 3 characters or less. That new report would be on a sheet
titled, "Short Names". What I want to accomplish is having a sheet that
lists all the 3 character last names or less from the main report called "All
Records". Names like "Ray", "Fox", "Lee" or " Hu". Thanks

 

[Tom Ogilvy]

Sub GetShortNames()
Dim sh as Worksheet, sh1 as Worksheet
Dim rw as Long, s as String, ipos as long
Dim cell as Range, rng as Range
Set sh = Activesheet
With sh
set rng = .Range(.Cells(2,"D"),.Cells(rows.count,"D").End(xlup))
End with
rw = 1
worksheets.Add after:=sheets(sheets.count)
set sh1 = Activesheet
sh.Activate
for each cell in rng
s = Replace(Trim(cell.Value)," ","")
ipos = instr(1,s,",",vbTextCompare)
if ipos <= 4 and ipos <> 0 then
s1 = left(s,ipos-1)
sh1.Cells(rw,1).Value = s1
rw = rw + 1
end if
Next
End Sub

 

[Guest]

Hi Tom,

This worked great, however I didn't state my question properly, I would like
to copy the entire row for each of these cases of names with 3 characters or
less. I was looking at the code and not quite sure where I would specify
that. Also how would I specify to place this data in the sheet called "Short
Names" rather than the last sheet in the workbook.

Thanks so much for your help! Enjoy your day.
Joyce

 

[Tom Ogilvy]

Sub GetShortNames()
Dim sh as Worksheet, sh1 as Worksheet
Dim rw as Long, s as String, ipos as long
Dim cell as Range, rng as Range
Set sh = Activesheet
With sh
set rng = .Range(.Cells(2,"D"),.Cells(rows.count,"D").End(xlup))
End with
rw = 1
'worksheets.Add after:=sheets(sheets.count)
set sh1 = Worksheets("Short")
sh.Activate
for each cell in rng
s = Replace(Trim(cell.Value)," ","")
ipos = instr(1,s,",",vbTextCompare)
if ipos <= 4 and ipos <> 0 then
's1 = left(s,ipos-1)
sh1.Cells(rw,1).Value = cell.Value
'or for the whole row
'cell.EntireRow.copy sh1.Cells(rw,1)
rw = rw + 1
end if
Next
End Sub