Cut/paste cells based on text color or certain characters

[michaelberrier]

In a bank export spreadsheet, transaction amounts are listed in a
single column and are separated into credits and debits by color and
parenthesis (credit=black, debit=(red)).

I would like to run a sub to move all the debits into the next column,
and I'm guessing the best way to do this is by using and IF statement
that depends on the presence of red text or the parenthesis.

Any help on the routine will be appreciated.

 

[Guest]

The following looks at column A. If it finds cells with red font, it moves
the contents to column B:

Sub berrier()
Dim r As Range
Set r = Nothing
n = 100
For i = 1 To n
If Cells(i, "A").Font.ColorIndex = 3 Then
If r Is Nothing Then
Set r = Cells(i, "A")
Else
Set r = Union(r, Cells(i, "A"))
End If
End If
Next

r.Offset(0, 1) = r.Value
r.Clear
End Sub

I did not check the () as they may be only in the formatting.

 

[michaelberrier]

The following looks at column A. If it finds cells with red font, it moves
the contents to column B:

Sub berrier()
Dim r As Range
Set r = Nothing
n = 100
For i = 1 To n
If Cells(i, "A").Font.ColorIndex = 3 Then
If r Is Nothing Then
Set r = Cells(i, "A")
Else
Set r = Union(r, Cells(i, "A"))
End If
End If
Next

r.Offset(0, 1) = r.Value
r.Clear
End Sub

I did not check the () as they may be only in the formatting.

Thanks for looking...

Tried that code adjusted for my column, which is D, and get this
error:

"Object variable or With block variable not set" on this line

r.Offset(0, 1) = r.Value

I've tried a little tweaking, but can't make it work.

Thanks again

 

[Guest]

Sub berrier()
Dim r As Range
Set r = Nothing
n = 100
For i = 1 To n
If Cells(i, "D").Font.ColorIndex = 3 Then
If r Is Nothing Then
Set r = Cells(i, "D")
Else
Set r = Union(r, Cells(i, "D"))
End If
End If
Next

r.Offset(0, 1) = r.Value
r.Clear
End Sub


The error means that the code did not find any cells in column D with Red
font (#3). For this type of code to work, the color must be "firm", that is
not the result of conditional formatting.

 

[michaelberrier]

Sub berrier()
Dim r As Range
Set r = Nothing
n = 100
For i = 1 To n
If Cells(i, "D").Font.ColorIndex = 3 Then
If r Is Nothing Then
Set r = Cells(i, "D")
Else
Set r = Union(r, Cells(i, "D"))
End If
End If
Next

r.Offset(0, 1) = r.Value
r.Clear
End Sub

The error means that the code did not find any cells in column D with Red
font (#3). For this type of code to work, the color must be "firm", that is
not the result of conditional formatting.

Ok...I'm an idiot.

The number isn't Red...it's a negative number formatted as
(Red)...talk about a rookie mistake.

 

[michaelberrier]

Ok...I'm an idiot.

The number isn't Red...it's a negative number formatted as
(Red)...talk about a rookie mistake.

Alright, I changed this:
If Cells(i, "D").Font.ColorIndex = 3 Then
To this:
If Cells(i, "D") < 0

Now, it moves all the negative numbers to the next column, but then
there is weirdness:
Some cells transfer correctly;
Some transfer as $200, regardless of value
Others end up as #N/A errors...

What have I done?

 

[michaelberrier]

Alright, I changed this:
If Cells(i, "D").Font.ColorIndex = 3 Then
To this:
If Cells(i, "D") < 0

Now, it moves all the negative numbers to the next column, but then
there is weirdness:
Some cells transfer correctly;
Some transfer as $200, regardless of value
Others end up as #N/A errors...

What have I done?

Update....

Only the first three negative numbered cells transfer correctly, the
rest....
-$200 is the first negative value. It is copied on most of the
following cells. This duplicates regardless of what value is in the
first cell, so it seems something in the code is hung on the first
value.
The values from the second and third negative cell appear
occasionally, and always sequentially.
Other values return as #N/A....

The code works perfectly on the Red text cells as described before.

It seems the problem occurs after a cell that doesn't fit the criteria
(i.e.: a positive value).
Something seems broken in the second part of the IF statement then, I
would think.

 

[Guest]

You have done a good job modifying the code on your own and you were very
close.

Sub berrier_II()
'
' The Sequel
'

Dim r As Range, rr As Range
Set r = Nothing
n = 100
For i = 1 To n
If Cells(i, "D").Value < 0 Then
If r Is Nothing Then
Set r = Cells(i, "D")
Else
Set r = Union(r, Cells(i, "D"))
End If
End If
Next


For Each rr In r
rr.Copy rr.Offset(0, 1)
rr.Clear
Next
End Sub


Here we modified the test in the loop. We also modified the last part to do
a Copy/Paste. It should work unless there are any formula references that
might get botched.

Give it a try and let me know how you made out.

In Any Case:

Have a good weekend!

 

[michaelberrier]

You have done a good job modifying the code on your own and you were very
close.

Sub berrier_II()
'
' The Sequel
'

Dim r As Range, rr As Range
Set r = Nothing
n = 100
For i = 1 To n
If Cells(i, "D").Value < 0 Then
If r Is Nothing Then
Set r = Cells(i, "D")
Else
Set r = Union(r, Cells(i, "D"))
End If
End If
Next

For Each rr In r
rr.Copy rr.Offset(0, 1)
rr.Clear
Next
End Sub

Here we modified the test in the loop. We also modified the last part to do
a Copy/Paste. It should work unless there are any formula references that
might get botched.

Give it a try and let me know how you made out.

In Any Case:

Have a good weekend!

That did it. I guess the second range, rr, was the ticket, eh?

Thanks again.