Thread
:
Help for final touch up to my code
View Single Post
#
2
Posted to microsoft.public.excel.programming
Don Guillett[_4_]
external usenet poster
Posts: 2,337
Help for final touch up to my code
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
--
Don Guillett
SalesAid Software
"Bimal" wrote in message
m...
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
Reply With Quote
Don Guillett[_4_]
View Public Profile
Find all posts by Don Guillett[_4_]