****al,
Is this what you want? If not, send me an example workbook
)

Sub SumByParty()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastrow As Long, r As Long, srow As Long, nrow As Long
Dim OpAmt As Double, PendAmt As Double

Set ws1 = Worksheets("Sheet1") ' <=== Change
Set ws2 = Worksheets("Sheet2") ' <=== Change

ws1.Activate
With ws1

lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
ws2.Range("a1:g1") = Array("Party", "Date", "Ref", "Op. Amt", "Pending
Amt", "Due date", "Overdue Date")

Set Outrng = ws2.Range("a2")
srow = 2
r = 2

Do
OpAmt = .Cells(r, 3)
PendAmt = .Cells(r, 4)
r = r + 1
Do While .Cells(r, 7) = "" And r <= lastrow
OpAmt = OpAmt + .Cells(r, 3)
PendAmt = PendAmt + .Cells(r, 4)
r = r + 1
Loop
nrow = r - srow
.Cells(srow, 1).Resize(nrow, 6).Copy Outrng.Offset(0, 1)
Outrng.Resize(nrow) = .Cells(srow, 7)
Outrng.Offset(nrow - 1, 7) = OpAmt
Outrng.Offset(nrow - 1, 8) = PendAmt
Set Outrng = Outrng.Offset(nrow + 1, 0)
srow = r
Loop While r <= lastrow

End With
End Sub
"****al shah" wrote:

Thanks you very much it's working..
But i want subtotal at end of each party dates are over and not end of the
data, is this possible? one more thing can party name come below party filed.

thanks again for reply.

****al

"Toppers" wrote:

Hi,
Try this:

Sub SumByParty()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastrow As Long, r As Long, srow As Long, nrow As Long
Dim OpAmt As Double, PendAmt As Double

Set ws1 = Worksheets("Sheet1") ' <=== Change
Set ws2 = Worksheets("Sheet2") ' <=== Change

ws1.Activate
With ws1

lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
ws2.Range("a1:g1") = Array("Party", "Date", "Ref", "Op. Amt", "Pending
Amt", "Due date", "Overdue Date")

Set Outrng = ws2.Range("a2")
srow = 2
r = 2

Do
OpAmt = .Cells(r, 3)
PendAmt = .Cells(r, 4)
r = r + 1
Do While .Cells(r, 7) = "" And r <= lastrow
OpAmt = OpAmt + .Cells(r, 3)
PendAmt = PendAmt + .Cells(r, 4)
r = r + 1
Loop
nrow = r - srow
.Cells(srow, 1).Resize(nrow, 6).Copy Outrng.Offset(0, 1)
Outrng.Resize(nrow) = .Cells(srow, 7)
Outrng.Offset(nrow + 1, 3) = OpAmt
Outrng.Offset(nrow + 1, 4) = PendAmt
Set Outrng = Outrng.Offset(nrow + 4, 0)
srow = r
Loop While r <= lastrow

End With
End Sub



"****al shah" wrote:

Thanks for Reply. Toppers

My Data layout is like...
a1, b1, c1, d1, e1,
f1
Date, Ref, Op. Amt, Pending Amt, Due date, Overdue day
00123ABC & Co.,
10-dec-05, 0101, 56700, 34099, 12-jan-06, 30
12-dec-05, 0102, 46100, 24090, 15-jan-06, 35
00125xyz & Co.,
17-dec-05, 0111, 56700, 4092, 22-jan-06, 30
22-dec-05, 0002, 23160, 1790, 25-jan-06, 15
29-dec-05, 0501, 16800, 2099, 12-jan-06, 20
31-dec-05, 0302, 86120, 6000, 25-jan-06, 33

I want output like...

A1, b1, c1, d1, e1,
f1, g1
Party, Date, Ref, Op. Amt, Pending Amt, Due
date, Overdue
00123ABC & Co.,10-dec-05, 0101, 56700, 34099, 12-jan-06, 30
00123ABC & Co.,12-dec-05, 0102, 46100, 24090, 15-jan-06, 35
Party subtotal 102800 58189
00125xyz & Co.,17-dec-05, 0111, 56700, 4092, 22-jan-06,
30
00125xyz & Co.,22-dec-05, 0002, 23160, 1790, 25-jan-06,
15
00125xyz & Co.,29-dec-05, 0501, 16800, 2099, 12-jan-06,
20
00125xyz & Co.,31-dec-05, 0302, 86120, 6000, 25-jan-06,
33
Party Subtotal 345590 13451
any help

"Toppers" wrote:

Can you give an example of the data layout (columns/fields) and how you want
the output?

"****al shah" wrote:

I have exported data from other prg. Where I have filed like Date, Ref no.
Op. amt., Pending amt, due date and overdue date.

Where in date filed I have party name and dates want to transfer that name
from date filed into new column and than subtotal as per party name.

How do I transfer name from date filed into new column and than subtotal all
filed with party name.

Any Help thank in advance.

****al