Help with a Macro?

[Mascot]

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

 

[stevebriz]

Mascot,
is this what you mean?
you want for
P100161000 Cash
eg:
col A | col b |
Cash | P100161000 |

 

[Tom Ogilvy]

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

 

[Mascot]

Hi Stevebriz,

This is what I mean.

ColumnA | ColumnB
* J101 J101 | P100565000 Inventory

 

[Mascot]

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]

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

 

[Mascot]

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]

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.

 

[Mascot]

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]

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