Help for final touch up to my code

B

Bimal

Hi groupe members,
I have joind NG recently and this is my first code. I have searched
the old
posts and collected many code snippets. I have tried to
assamble/modify the
code to suit my requirement which is given below. This code takes more
then two mins for execution during which it scans 3 sheets and around
more
then 8000 rows which is growing day by day. Since I am new in the VBA,
you
may think it as a foolish way of code writing, I have collected bits
and
pieces from old posts of experts and joined them. I will be thankfull
to
you if some body suggests a way to improve the speed and also other
efficient way of handeling this.

My 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

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

Worksheets.Add
ActiveSheet.Name = "TEMP"

Set Sht3 = Sheets("TEMP")

Sht2.Cells.Clear

Sht1.Select
Ref1 = 10

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

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

Sht1.AutoFilterMode = False

Application.DisplayAlerts = False

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


Sht3.Delete

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

Do While IsEmpty(ActiveCell.Offset(0, -1)) = False

ActiveCell.FormulaR1C1 = "Receipt"

ActiveCell.Offset(1, 0).Select

Loop

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")

Sht1.Select
Ref1 = 8

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

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

Sht1.AutoFilterMode = False

Application.DisplayAlerts = False


Sht3.Activate

Range("B:B,C:C,D:D,E:E,M:M,N:N,O:O").Select
Selection.Delete Shift:=xlToLeft

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

Do While IsEmpty(ActiveCell.Offset(0, -1)) = False

ActiveCell.FormulaR1C1 = "Issue"

ActiveCell.Offset(1, 0).Select

Loop
Rows("1:1").Select
Selection.Delete Shift:=xlUp

ActiveSheet.UsedRange.Select

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

Sht2.Select
Columns("A:A").Select
Selection.NumberFormat = "dd-mmm-yy"
Range("D19").Select
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")

Sht1.Select
Ref1 = 3

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

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

Sht1.AutoFilterMode = False
Application.DisplayAlerts = False
Sht3.Activate

Range("B:B").Select
Selection.Delete Shift:=xlToLeft

Columns("B:C").Select
Selection.Cut
Columns("F:G").Select
Selection.Insert Shift:=xlToRight

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

Do While IsEmpty(ActiveCell.Offset(0, -1)) = False

ActiveCell.FormulaR1C1 = "Returned"

ActiveCell.Offset(1, 0).Select

Loop
Rows("1:1").Select
Selection.Delete Shift:=xlUp

ActiveSheet.UsedRange.Select

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


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


Sht3.Delete

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

' +++++++ COMMON

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


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

Range("I2").Select

If Range("H2").Value = "Receipt" Then
ActiveCell.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
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.Offset(-1, 0).Value = ""

If ActiveCell.Offset(0, -1).Value = "Issue" Then
ActiveCell.Value = (ActiveCell.Offset(-1, 0).Value -
ActiveCell.Offset(0, -2).Value)
ActiveCell.Offset(1, 0).Select
ElseIf ActiveCell.Offset(0, -1).Value = "Receipt" Then
ActiveCell.Value = (ActiveCell.Offset(-1, 0).Value +
ActiveCell.Offset(0, -2).Value)
ActiveCell.Offset(1, 0).Select
ElseIf ActiveCell.Offset(0, -1).Value = "Returned" Then
ActiveCell.Value = (ActiveCell.Offset(-1, 0).Value +
ActiveCell.Offset(0, -2).Value)
ActiveCell.Offset(1, 0).Select
ElseIf ActiveCell.Offset(0, -1).Value = "Type" Then
Range("A1").Select
Exit Sub
ElseIf ActiveCell.Offset(0, -1).Value = "" Then
Range("A1").Select
Exit Sub

End If

Loop

Application.ScreenUpdating = True

End Sub

############

Any help is appreciated,
Thanks and Regards,
Bimal
 
D

Don Guillett

One of the things you can do is get rid of the unnecessary selects. Example
(Test as you go along)

with Sht3 'You do NOT have to go there
. Range("A:A,E:E,D:D,J:J,K:K,L:L,M:M,N:N").Copy
Sheets("Report").Range("A1")
. Columns("A:A").NumberFormat = "dd-mmm-yy"
end with
===
instead of

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

Bob Phillips

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)
 
B

Bimal

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
 

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

Count to Table Format 0
help with syntax for copy and pasting rows across sheets 4
How to modify VBA code for Add-in? 1
Hlp! Adv Filter - Non-Contiguous rows don't copy 11
Macro for cross referencing 8
Help me4 2
works in 2007 but not in 2010 0
Code does not error but no copy either 4

Top