Macro: Add trimming step to existing macro

[jeffcoleky]

This macro currently copies a range of cell which I select and then exports it to a CSV for me. I love it but i need it to do a little more..

Application.DisplayAlerts = False
Set myrng = ActiveWindow.RangeSelection
Set newbook = Workbooks.Add
With newbook
.Title = "export"
.SaveAs Filename:="C:\export\Workbook", FileFormat:=xlCSV
End With

myrng.Copy
Windows("workbook.csv").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks("workbook.csv").Save
Workbooks("workbook.csv").Close
Application.DisplayAlerts = True
On Error Resume Next
MsgBox ("Selection Successfully Exported")

End Sub

I need the macro to copy, and paste as it currently does, but THEN TRIM off the last word from each cell.

The data will always be an address, in the below format:

Example:

CURRENT RESULT OF MACRO

3017 Jeffrey Drive
2429 Middlerose Cir
6400 Skyline Dr.
0144 Nocturne Dr
3748 Trinity Park Drive
4301 Sir Barton Road
9331 Southern Ave
9173 Novell Dr
18054 Mondamon Dr
4155 Twin Oak Ln
8032 Guy Dr
7263 S 6th St.
9452 Determine Ln.
5055 Bluegrass Ave

DESIRED RESULT USING MACRO

3017 Jeffrey
2429 Middlerose
6400 Skyline
0144 Nocturne
3748 Trinity Park
4301 Sir Barton
9331 Southern
9173 Novell
18054 Mondamon
4155 Twin Oak
8032 Guy
7263 S 6th
9452 Determine
5055 Bluegrass

Can anyone suggest changes to I could make to the macro to make this work?

 

[Ruddles]

Declare a couple of variables at the top:-

dim ocell as range
dim iptr as integer

Then stick this code in between the .PasteSpecial and the .Save:-

for each ocell in selection
iptr=instrrev(ocell.value," ")
if iptr>1 then ocell=left(ocell.value,iptr-1)
next ocell

Test on a copy of your data.

Any good?

 

[jeffcoleky]

Yes, that worked exactly as intended. Thank you for putting the time into that to help me.

I just came up with a small problem, one I hadn't realized could happen.

Occassionally, the pre-macro data already has the street suffix removed. Is there a way to add an IF statement to the formula? The idea would be to say that "if there is only a number followed by a single word, then don't run on that line"

Your help is greatly appreciated...again..

Example Data:


5055 Bluegrass
123 count
5555 Mystreet


Here is the complete code thus far:

Dim ocell As Range
Dim iptr As Integer

Application.DisplayAlerts = False
Set myrng = ActiveWindow.RangeSelection
Set newbook = Workbooks.Add
With newbook
.Title = "export"
.SaveAs Filename:="C:\export\Workbook", FileFormat:=xlCSV
End With

myrng.Copy
Windows("workbook.csv").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

For Each ocell In Selection
iptr = InStrRev(ocell.Value, " ")
If iptr > 1 Then ocell = Left(ocell.Value, iptr - 1)
Next ocell

Workbooks("workbook.csv").Save
Workbooks("workbook.csv").Close
Application.DisplayAlerts = True
On Error Resume Next
MsgBox ("Selection Successfully Exported")

End Sub

 

[Ruddles]

"if there is only a number followed by a single word, then don't run on that line"

So it would run on these lines:-

<TABLE style="WIDTH: 83pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=111><COLGROUP><COL style="WIDTH: 83pt; mso-width-source: userset; mso-width-alt: 4059" width=111><TBODY><TR style="HEIGHT: 15.75pt" height=21><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; WIDTH: 83pt; HEIGHT: 15.75pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" id=td_post_2731190 class=xl63 height=21 width=111>4301 Sir Barton</TD></TR><TR style="HEIGHT: 15.75pt" height=21><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 15.75pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 height=21>4155 Twin Oak</TD></TR><TR style="HEIGHT: 15.75pt" height=21><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 15.75pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 height=21>7263 S 6th</TD></TR></TBODY></TABLE>

Is that correct?

 

[jeffcoleky]

So it would run on these lines:-

<TABLE style="WIDTH: 83pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=111><COLGROUP><COL style="WIDTH: 83pt; mso-width-source: userset; mso-width-alt: 4059" width=111><TBODY><TR style="HEIGHT: 15.75pt" height=21><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; WIDTH: 83pt; HEIGHT: 15.75pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" id=td_post_2731190 class=xl63 height=21 width=111>4301 Sir Barton</TD></TR><TR style="HEIGHT: 15.75pt" height=21><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 15.75pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 height=21>4155 Twin Oak</TD></TR><TR style="HEIGHT: 15.75pt" height=21><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 15.75pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 height=21>7263 S 6th</TD></TR></TBODY></TABLE>

Is that correct?

Ruddles, you are correct. It would run on BOTH kinds. Addresses both with and without the Suffix.

4301 Sir Barton
4155 Twin Oak
7263 S 6th
1234 Count Rd
123 Mary
112 Sell

 

[Ruddles]

Replace the entire For..Next loop with this:-

[FONT=Fixedsys]  For Each ocell In Selection
    iptr = InStrRev(ocell.Value, " ")
    If iptr > 1 Then
      If IsNumeric(Left(ocell.Text, InStr(ocell.Text, " ") - 1)) Then
        If Len(ocell.Text) > Len(Replace(ocell.Text, " ", "")) + 1 Then
          ocell = Left(ocell.Value, iptr - 1)
        End If
      End If
    End If
  Next ocell[/FONT]

Any good?

 

[jeffcoleky]

Replace the entire For..Next loop with this:-

[FONT=Fixedsys]  For Each ocell In Selection
    iptr = InStrRev(ocell.Value, " ")
    If iptr > 1 Then
      If IsNumeric(Left(ocell.Text, InStr(ocell.Text, " ") - 1)) Then
        If Len(ocell.Text) > Len(Replace(ocell.Text, " ", "")) + 1 Then
          ocell = Left(ocell.Value, iptr - 1)
        End If
      End If
    End If
  Next ocell[/FONT]

Any good?

Sorry for taking so long to respond, but YES, it works PERFECTLY. What a HUGE help! thanks.