Need code - new user

N

nat

Hello,
Can someone help with the code, please?
Here is the example of the table (let's say on Sheet1):
A B C
1 Depart Num Acct Num Acct Balance
2 01 1111 100.00
3 02 1111 50.00
4 03 2222 150.00
5 01 3333 200.00
6 05 3333 10.00

I need the macro to do the following:
- if the total balance per account is equal or greater
than $50
- select all rows for that account, and
- copy them to Sheet2
- after all rows (meeting the requirements are copied),
insert lines to subtotal balance for each account.
Note: the number of rows in the first table will be
changing on a monthly basis.
 
B

Bob Phillips

Nat,

Is this what you want?

Dim i As Long
Dim cLastRow As Long
Dim iRow As Long
Dim nACcount As Long
Dim nBalance As Long
Dim fFirst As Boolean

cLastRow = Cells(Rows.Count, "A").End(xlUp).Row
nACcount = Range("B2").Value
nBalance = 0
iRow = 1
fFirst = True
For i = 2 To cLastRow
If Cells(i, "B").Value <> nACcount Then
nACcount = Cells(i, "B").Value
With Worksheets("Sheet2").Cells(iRow, "C")
.Value = nBalance
.Font.Bold = True
End With
nBalance = 0
iRow = iRow + 1
End If
nBalance = nBalance + Cells(i, "C").Value
Cells(i, "A").EntireRow.Copy _
Destination:=Worksheets("Sheet2").Cells(iRow, "A")
iRow = iRow + 1
Next i
nACcount = Cells(i, "B").Value
With Worksheets("Sheet2").Cells(iRow, "C")
.Value = nBalance
.Font.Bold = True
End With

End Sub


--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)
 
N

nat

Bob
I'm not very familiar with the code but I think it should
have one more condition:
- if the balance per account is equal or greater
than $50.00, than it should copy the rows to another sheet
- if not, than no copy needed.

Can you modify to reflect this condition? Thank you.
 
B

Bob Phillips

Nat,

Sorry about that. I noticed the condition, but built the basic code first,
and then forgot it.

Try this instead

Sub Accounts()
Dim i As Long, iRow As Long
Dim iStart As Long, iEnd As Long
Dim cLastRow As Long
Dim nACcount As Long, nBalance As Long
Dim fFirst As Boolean
Dim sRows As String

cLastRow = Cells(Rows.Count, "A").End(xlUp).Row
nACcount = Range("B2").Value
nBalance = 0
iRow = 1
iStart = 2: iEnd = iStart
fFirst = True
For i = 2 To cLastRow
If Cells(i, "B").Value = nACcount Then
iEnd = iEnd + 1
nBalance = nBalance + Cells(i, "C").Value
Else
nACcount = Cells(i, "B").Value
If nBalance > 50 Then
Rows(iStart & ":" & iEnd - 1).Copy
Destination:=Worksheets("Sheet2").Cells(iRow, "A")
iRow = iRow + iEnd - 1 - iStart + 1
With Worksheets("Sheet2").Cells(iRow, "C")
.Value = nBalance
.Font.Bold = True
End With
iRow = iRow + 1
End If
nBalance = 0
iStart = iEnd
i = i - 1
End If
Next i

If nBalance > 50 Then
Rows(iStart & ":" & iEnd - 1).Copy
Destination:=Worksheets("Sheet2").Cells(iRow, "A")
With Worksheets("Sheet2").Cells(iRow + 1, "C")
.Value = nBalance
.Font.Bold = True
End With
End If

End Sub


--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)
 
N

nat

Bob,
Thank you very much for the code. When I've tried to run
it, i've got a syntax error in Destination:= line. Any
idea why?
 
D

Doug Glancy

I haven't been following along here, but it looks like the "line
continuation" character(underscore followed by a space) in the middle of the
Copy statement is missing, i.e.:

Rows(iStart & ":" & iEnd - 1).Copy _
Destination:=Worksheets("Sheet2").Cells(iRow, "A")

Could just be the formatting on my screen, but it looks suspicious.

hth,

Doug
 
N

nat

Thank you Doug.
The continuation character fixed the syntax error;
however, when I've tried to run it on my test table, the
total on sheet2 for the las account "3333" is correct
(=210) but only one row (with $200 balance) shows up. Any
idea why the row with $10 balance is not showing? Can you
correct the code? Thank you in advance.
 
D

Doug Glancy

nat,

I am at work now. If no one else answers this I'll try to figure out later.

Doug
 
D

Doug Glancy

Nat,

I modified a line in the last copy section and it seems to work. Also, I
wrote another routine for you. It's the first one below. You can run it
from sheet1 or sheet2 or elsewhere in the workbook:

Sub Accounts2()

Dim rw, copy_range, sum_cell, cel As Range
Dim group_count, row_count, i As Integer
Dim delete_next As Boolean

Set copy_range = Worksheets("Sheet1").Rows(2).EntireRow
For Each rw In Worksheets("Sheet1").Range("B2",
Worksheets("Sheet1").Cells(Worksheets("Sheet1").Rows.Count, 2).End(xlUp))
If Worksheets("Sheet1").Cells(rw.Row, "B") =
Worksheets("Sheet1").Cells(rw.Row + 1, "B") Then
Set copy_range =
Worksheets("Sheet1").Range(copy_range.Resize(copy_range.Rows.Count + 1,
1).EntireRow.Address)
Else
group_count = group_count + 1
copy_range.Copy Destination:=Worksheets("Sheet2").Cells(rw.Row - 1 +
group_count - copy_range.Rows.Count, 1)
Set sum_cell = Worksheets("Sheet2").Cells(rw.Row - 1 + group_count,
"C")
sum_cell.Formula = "=sum(" & sum_cell.Offset(-1, 0).Address & ":" &
sum_cell.Offset(-copy_range.Rows.Count, 0).Address & ")"
sum_cell.Font.Bold = True
Set copy_range = Worksheets("Sheet1").Range(Rows(rw.Row +
1).EntireRow.Address)
End If
row_count = rw.Row - 1 + group_count
Next rw

delete_next = False
For i = row_count To 1 Step -1
Set cel = Worksheets("Sheet2").Cells(i, 3)
If cel.HasFormula Then
If cel <= 50 Then
delete_next = True
cel.EntireRow.Delete
Else
delete_next = False
End If
ElseIf delete_next = True Then
cel.EntireRow.Delete
End If
Next i

End Sub


Here's the modified original code:

Sub Accounts()
Dim i As Long, iRow As Long
Dim iStart As Long, iEnd As Long
Dim cLastRow As Long
Dim nACcount As Long, nBalance As Long
Dim fFirst As Boolean
Dim sRows As String

cLastRow = Cells(Rows.Count, "A").End(xlUp).Row
nACcount = Range("B2").Value
nBalance = 0
iRow = 1
iStart = 2: iEnd = iStart
fFirst = True
For i = 2 To cLastRow
If Cells(i, "B").Value = nACcount Then
iEnd = iEnd + 1
nBalance = nBalance + Cells(i, "C").Value
Else
nACcount = Cells(i, "B").Value
If nBalance > 50 Then
Rows(iStart & ":" & iEnd - 1).Copy _
Destination:=Worksheets("Sheet2").Cells(iRow, "A")
iRow = iRow + iEnd - iStart
With Worksheets("Sheet2").Cells(iRow, "C")
.Value = nBalance
.Font.Bold = True
End With
iRow = iRow + 1
End If
nBalance = 0
iStart = iEnd
i = i - 1
End If
Next i

If nBalance > 50 Then
Rows(iStart & ":" & iEnd - 1).Copy _
Destination:=Worksheets("Sheet2").Cells(iRow, "A")
With Worksheets("Sheet2").Cells(iRow + iEnd - iStart, "C")
.Value = nBalance
.Font.Bold = True
End With
End If

End Sub

hth,

Doug
 
G

Guest

Doug,
Thank you very much. It works!!!!!!!!! Is there any way
to modify the code to format the total balance lines (on
sheet2)like this: Acct 1111 Total 150 (in bold surrounded
by top and bottom border lines)?
-----Original Message-----
Nat,

I modified a line in the last copy section and it seems to work. Also, I
wrote another routine for you. It's the first one below. You can run it
from sheet1 or sheet2 or elsewhere in the workbook:

Sub Accounts2()

Dim rw, copy_range, sum_cell, cel As Range
Dim group_count, row_count, i As Integer
Dim delete_next As Boolean

Set copy_range = Worksheets("Sheet1").Rows(2).EntireRow
For Each rw In Worksheets("Sheet1").Range("B2",
Worksheets("Sheet1").Cells(Worksheets
Click to expand...
("Sheet1").Rows.Count, 2).End(xlUp))
 
D

Doug Glancy

Nat,

I cleaned up a couple of other things and made the changes you're looking
for. The code is getting longer! Let me know how this works for you:

Sub Accounts2()

Dim rw, copy_range, sum_cell, cel As Range
Dim group_count, row_count, i As Integer
Dim delete_next As Boolean

Application.ScreenUpdating = False
Worksheets("Sheet2").Cells.Font.Bold = False
On Error GoTo error
Set copy_range = Worksheets("Sheet1").Rows(2).EntireRow
For Each rw In Worksheets("Sheet1").Range("B2",
Worksheets("Sheet1").Cells(Worksheets("Sheet1").Rows.Count, 2).End(xlUp))
If Worksheets("Sheet1").Cells(rw.Row, "B") =
Worksheets("Sheet1").Cells(rw.Row + 1, "B") Then
Set copy_range =
Worksheets("Sheet1").Range(copy_range.Resize(copy_range.Rows.Count + 1,
1).EntireRow.Address)
Else
group_count = group_count + 1
copy_range.Copy
Worksheets("Sheet2").Cells(rw.Row - 1 + group_count -
copy_range.Rows.Count, 1).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Set sum_cell = Worksheets("Sheet2").Cells(rw.Row - 1 + group_count,
"C")

With sum_cell
.Formula = "=sum(" & .Offset(-1, 0).Address & ":" &
..Offset(-copy_range.Rows.Count, 0).Address & ")"
.NumberFormat = """Total""_(* #,##0_);_(* (#,##0);_(*
""-""??_);_(@_)"
.Offset(0, -2) = "Acct "
.Offset(0, -1) = .Offset(-1, -1)
With Range(.Offset(0, -2).Address, .Offset(0, 0).Address)
.Font.Bold = True
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
End With
End With
End With
Set copy_range = Worksheets("Sheet1").Range(Rows(rw.Row +
1).EntireRow.Address)
End If
row_count = rw.Row - 1 + group_count
Next rw

delete_next = False
For i = row_count To 1 Step -1
Set cel = Worksheets("Sheet2").Cells(i, 3)
If cel.HasFormula Then
If cel < 50 Then
delete_next = True
cel.EntireRow.Delete
Else
delete_next = False
End If
ElseIf delete_next = True Then
cel.EntireRow.Delete
End If
Next i

Worksheets("Sheet2").Range("A1").Select

error:
Application.ScreenUpdating = True

End Sub

hth,

Doug
 
N

Nat

Hi Doug,
Thanks for being there for me. When I've tried to copy
the code, the section below was highlighted in red (giving
me a compile error: end of statement required). I was
able to fix the .Formula line by deleting an extra period
(if it is in fact extra) before the Offset.
But .NumberFormat line is still highlighted in red with
the cursor blinking on the secon ? sign in (*""-""??_).
Any idea why?
Some day I hope to learn what all of these means. Thank
you for all of you help.


With sum_cell
.Formula = "=sum(" & .Offset(-1, 0).Address
& ":" &
...Offset(-copy_range.Rows.Count, 0).Address & ")"
.NumberFormat = """Total""_(* #,##0_);_(*
(#,##0);_(*
""-""??_);_(@_)"




-----Original Message-----
Nat,

I cleaned up a couple of other things and made the changes you're looking
for. The code is getting longer! Let me know how this works for you:

Sub Accounts2()

Dim rw, copy_range, sum_cell, cel As Range
Dim group_count, row_count, i As Integer
Dim delete_next As Boolean

Application.ScreenUpdating = False
Worksheets("Sheet2").Cells.Font.Bold = False
On Error GoTo error
Set copy_range = Worksheets("Sheet1").Rows(2).EntireRow
For Each rw In Worksheets("Sheet1").Range("B2",
Worksheets("Sheet1").Cells(Worksheets
Click to expand...
("Sheet1").Rows.Count, 2).End(xlUp))
 
D

Doug Glancy

Nat,

Don't know how I got the extra period in there, it's not in the code in my
worksheet - anyways you fixed it.

For the NumberFormat line, the following code needs to be all one line in
the VBE (the editor):

.NumberFormat = """Total""_(* #,##0_);_(*
(#,##0);_(*
""-""??_);_(@_)"

Just be sure to leave the space that's after each of the asterisks. (You
could use a continuation character in VBE, which allows you to have lines of
code on more than one line in the editor, but since the character is an
underscore followed by a space (_ ) and can't be inside quotes, it might
drive you crazy trying to put them in the right place.)

So again just put the above code back onto one line, being sure to not to
delete the space that follows each asterisk

I hope that makes sense. Let me know.

Doug
 
G

Guest

Doug,
I fixed as you suggested and the macro ran fine with one
little problem: total acct lines on sheet2 were not
bolded and not surrounded with top and bottom border
lines. Instead, these lines and the bold format appeared
on sheet1 (which I do need). Can you try to fix it one
more time? (hopefully the last). Thank you.
 
D

Doug Glancy

Nat,

Sorry to draw this out. My inexperience is showing. That said, the fix is
simple (knock on wood).

Change the line:

With Range(.Offset(0, -2).Address, .Offset(0, 0).Address)
to
With Worksheets("Sheet2").Range(.Offset(0, -2).Address,
..Offset(0, 0).Address)

That works for me. Let me know if it works for you.

Doug
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Search for multiple cells with a row for matching criteria, then sum up certain column 3
Subtotals, not re-initializing 2
Help with lOOKUP? 6
Need help with lookup & sum range 2
Monthly account balance 2
Does anyone know how to create a lookup that will do this? 2
Need some expert help 1
Seeking Import/Link/Query workaround #Num! and #Error responses 6

Top