Thankx Bob and Don,
I was playing aroung with your suggetions.
Making calc manual save my 50% running time.
Also reducing the "selet" further reduced the running time. Now it is around
40-50sec.
It took so long because, I am novice in VBA asnd lot of errors kept arising
mainly due to my incomplete code in find and replace referances.

Thanks again for your help.

Regards,
Bimal


"Bob Phillips" wrote in message ...
Bimal,

That is a lot of code so you are asking a lot for us to look deeply at it.
However, one big thing jumps out, and that is the constant selecting of
sheets and cells. Selecting is costly, hugely inefficient, and rarely
necessary. I have appended my stab at what the code would look like without
the selects (but you will need to test). The other things you could do are,

- set Application.Calculation = xlCalculationManual at teh start,
xlCalculatgionAutomatic at the end

Here is the code


Sub Get_Ledger()

Ref2 = UserForm1.TextBox1.Text
Unload Me
Application.ScreenUpdating = False

'+++++++ IN

Dim Sht1 As Worksheet
Dim Sht2 As Worksheet
Dim Sht3 As Worksheet

Dim Ref1 As Variant

Dim i As Long

Set Sht1 = Sheets("In")
Set Sht2 = Sheets("Report")

Worksheets.Add
ActiveSheet.Name = "TEMP"

Set Sht3 = Sheets("TEMP")

Sht2.Cells.Clear

With Sht1
Ref1 = 10

.Cells(1, 1).AutoFilter Ref1, Ref2

.Cells(1, 1).CurrentRegion.Copy Sht3.Cells(1, 1)

.AutoFilterMode = False

Application.DisplayAlerts = False
End With

Sht3.Range("A:A,E:E,D:D,J:J,K:K,L:L,M:M,N:N").Copy
With Sheets("Report")
.Range("A1").PasteSpecial Paste:=xlValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
.Columns("A:A").NumberFormat = "dd-mmm-yy"
Application.CutCopyMode = False

Sht3.Delete

.Columns("H:H").Insert Shift:=xlToRight
.Range("H1").Value = "Type"

i = 0
With .Range("H2")
Do While IsEmpty(.Offset(i, -1)) = False
.FormulaR1C1 = "Receipt"
i = i + 1
Loop
End With
End With

Application.DisplayAlerts = True

Set Sht1 = Nothing
Set Sht2 = Nothing
Set Sht3 = Nothing
'++++++++ OUT

Set Sht1 = Sheets("Out")
Set Sht2 = Sheets("Report")

Worksheets.Add
ActiveSheet.Name = "TEMP"

Set Sht3 = Sheets("TEMP")

With Sht1
Ref1 = 8
.Cells(1, 1).AutoFilter Ref1, Ref2
.Cells(1, 1).CurrentRegion.Copy Sht3.Cells(1, 1)
.AutoFilterMode = False
End With

Application.DisplayAlerts = False

With Sht3
.Range("B:B,C:C,D:D,E:E,M:M,N:N,O:O").Delete Shift:=xlToLeft
.Columns("H:H").Insert Shift:=xlToRight
.Range("H1").Value = "Type"

i = 0
With Range("H2")
Do While IsEmpty(ActiveCell.Offset(0, -1)) = False
.FormulaR1C1 = "Issue"
i = i + 1
Loop
End With

.Rows("1:1").Delete Shift:=xlUp

.UsedRange.Copy Destination:=Worksheets("Report"). _
Cells(1, 1).End(xlDown).Offset(1, 0)
End With

Sht2.Columns("A:A").NumberFormat = "dd-mmm-yy"
Application.CutCopyMode = False

Sht3.Delete

Application.DisplayAlerts = True

Set Sht1 = Nothing
Set Sht2 = Nothing
Set Sht3 = Nothing


'++++++ RETURNED

Set Sht1 = Sheets("Returned")
Set Sht2 = Sheets("Report")

Worksheets.Add
ActiveSheet.Name = "TEMP"

Set Sht3 = Sheets("TEMP")

With Sht1
Ref1 = 3
.Cells(1, 1).AutoFilter Ref1, Ref2
.Cells(1, 1).CurrentRegion.Copy Sht3.Cells(1, 1)
.AutoFilterMode = False
End With

Application.DisplayAlerts = False

With Sht3
.Range("B:B").Delete Shift:=xlToLeft
.Columns("B:C").Cut
.Columns("F:G").Insert Shift:=xlToRight
.Columns("H:H").Insert Shift:=xlToRight
.Range("H1").Value = "Type"

i = 0
With .Range("H2")
Do While IsEmpty(ActiveCell.Offset(i, -1)) = False
.FormulaR1C1 = "Returned"
i = i + 1
Loop
End With

.Rows("1:1").Delete Shift:=xlUp

.UsedRange.Copy Destination:=Worksheets("Report"). _
Cells(1, 1).End(xlDown).Offset(1, 0)
End With

With Sht2
.Columns("A:A").NumberFormat = "dd-mmm-yy"

Application.CutCopyMode = False

Sht3.Delete

Application.DisplayAlerts = True
Set Sht1 = Nothing
Set Sht2 = Nothing
Set Sht3 = Nothing

' +++++++ COMMON

.Columns("I:I").Insert Shift:=xlToRight
.Range("I1").Value = "Balance"

.Cells.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

If .Range("H2").Value = "Receipt" Then
.Range("I2").Value = Range("I2").Offset(0, -2)
Else
MsgBox "There is no receipts, Please enter receipts first OR"
& vbNewLine & _
"Please sort the data"
Exit Sub
End If

With .Range("I2")
i = 0
.Offset(1, 0).Select
Do Until .Offset(i - 1, 0).Value = ""
If .Offset(i, -1).Value = "Issue" Then
.Value = (.Offset(i - 1, 0).Value -
.Offset(i, -2).Value)
ElseIf .Offset(i, -1).Value = "Receipt" Then
.Value = (.Offset(i - 1, 0).Value +
.Offset(i, -2).Value)
ElseIf .Offset(i, -1).Value = "Returned" Then
.Value = (.Offset(i - 1, 0).Value +
.Offset(i, -2).Value)
ElseIf .Offset(i, -1).Value = "Type" Then
.Range("A1").Select
Exit Sub
ElseIf .Offset(i, -1).Value = "" Then
.Range("A1").Select
Exit Sub
End If
Loop
End With

Application.ScreenUpdating = True

End Sub

--

HTH

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