Sub AAA()
'Add Data
Dim lastrow As Long
Dim i As Long, loc As String

Columns(1).ClearContents
lastrow = Cells(Rows.Count, 2).End(xlUp).Row

For i = lastrow To 1 Step -1
If Left(Trim(Cells(i, 2)), 1) < "*" Then
Cells(i, 1) = loc
Else
' this will make sure there is only one space
' between each
loc = Application.Trim(Cells(i, 2))
' optional
loc = Right(loc, Len(loc) - 2)
iloc = InStr(1, loc, " ", vbTextCompare)
loc = Left(loc, iloc - 1)
End If
Next

Dim rng As Range
On Error Resume Next
Set rng = Columns(1).SpecialCells(xlBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
rng.EntireRow.Delete
End If

End Sub

--
Regards,
Tom Ogilvy


"Mascot" wrote in message
...
Hi Tom,

Thanks for getting back to me. I checked it it works for the space after
the asteriks. I didn't realize this but there are actually 2 spaces. So
I
changed the code to the following.

Sub AAA()
'Add Data
Dim lastrow As Long
Dim i As Long, loc As String

Columns(1).ClearContents
lastrow = Cells(Rows.Count, 2).End(xlUp).Row

For i = lastrow To 1 Step -1
If Left(Trim(Cells(i, 2)), 1) < "*" Then
Cells(i, 1) = loc
Else
loc = Trim(Cells(i, 2))
Debug.Print loc
' optional
loc = Right(loc, Len(loc) - 3)
iloc = InStr(1, loc, " ", vbTextCompare)
loc = Left(loc, iloc - 1)
End If
Next

Dim rng As Range
On Error Resume Next
Set rng = Columns(1).SpecialCells(xlBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
rng.EntireRow.Delete
End If

but it didn't work. what am I missing?

Mascot

"Tom Ogilvy" wrote:

because I didn't notice there was a space after the asterisk and account
for
it.

Sub AAA()
'Add Data
Dim lastrow As Long
Dim i As Long, loc As String

Columns(1).ClearContents
lastrow = Cells(Rows.Count, 2).End(xlUp).Row

For i = lastrow To 1 Step -1
If Left(Trim(Cells(i, 2)), 1) < "*" Then
Cells(i, 1) = loc
Else
loc = Trim(Cells(i, 2))
Debug.Print loc
' optional
loc = Right(loc, Len(loc) - 2)
iloc = InStr(1, loc, " ", vbTextCompare)
loc = Left(loc, iloc - 1)
End If
Next

Dim rng As Range
On Error Resume Next
Set rng = Columns(1).SpecialCells(xlBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
rng.EntireRow.Delete
End If

End Sub


worked for me with the data you show.

--
Regards,
Tom Ogilvy


"Mascot" wrote:

Hi Tom,

This works great. Except when I include the optional code it ends up
just
deleting the whole sheet. Do you know what could be causing this?

Mascot

"Tom Ogilvy" wrote:

So just change the condition to check for:

'Add Data
Dim lastrow As Long
Dim i As Long, loc As String

Columns(1).ClearContents
lastrow = Cells(Rows.Count, 2).End(xlUp).Row

For i = lastrow To 1 Step -1
If Left(trim(Cells(i, 2)),1) < "*" Then
Cells(i, 1) = loc
Else
loc = Trim(Cells(i, 2))
' optional
' loc = right(loc,len(loc)-1)
' iloc = Instr(1,loc," ",vbTextcompare)
' loc = Left(loc,iloc-1)
End If
Next

Dim rng As Range
On Error Resume Next
Set rng = Columns(1).SpecialCells(xlBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
rng.EntireRow.Delete
End If

--
Regards,
Tom Ogilvy


"Mascot" wrote:

Hi Tom,

Thanks for replying. The asterisk is there. For some reason the
sytem we
use has it. However after I run the macro I am going to do a "Text
To
Columns" and change the location from this * J101 J101 to J101, so
I will be
getting rid of the asterik and have the location once instead of
twice. I
hope that helps.

Mascot

"Tom Ogilvy" wrote:

Assume the asterisk is not actually there and that was for
emphasis only.

Assume you are actually displaying column B and C and the
location is less
than 9 characters long. Further assume that accounts will be at
least 9
characters long

'Add Data
Dim lastrow As Long
Dim i As Long, loc As String

Columns(1).ClearContents
lastrow = Cells(Rows.Count, 2).End(xlUp).Row

For i = lastrow To 1 Step -1
If len(trim(Cells(i, 2))) 8 Then
Cells(i, 1) = loc
Else
loc = Cells(i, 2)
End If
Next

Dim rng As Range
On Error Resume Next
Set rng = Columns(1).SpecialCells(xlBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
rng.EntireRow.Delete
End If

--
Regards,
Tom Ogilvy


"Mascot" wrote:

Hi,

I have a spreadsheet were I have list of accounts and they are
catergorized
by location in the same column. For example Column B looks
like this.

P100161000 Cash
P100262000 AR
P100363000 AP
P100464000 Fixed Assets
P100565000 Inventory
* J101 J101
P100161000 Cash
P100262000 AR
P100363000 AP
P100565000 Inventory
* M102 M102

So it will list the accounts and then the last item will be the
location.
What I want to do is have the location in column A right next
to the account.
Does anyone have a macro that can go down the list and put the
location in
front
of the account? And then delete the row with the location.

By the way I have a macro that will do it if one is
alphanumeric and the
other is not, but as you can see both cells are alphanumeric in
this one. I
will copy the code I have below.

'Add Data
Dim lastrow As Long
Dim i As Long, loc As String

Columns(1).ClearContents
lastrow = Cells(Rows.Count, 2).End(xlUp).Row

For i = lastrow To 1 Step -1
If IsNumeric(Cells(i, 2)) Then
Cells(i, 1) = loc
Else
loc = Cells(i, 2)
End If
Next

Dim rng As Range
On Error Resume Next
Set rng = Columns(1).SpecialCells(xlBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
rng.EntireRow.Delete
End If

Thanks
Mascot