Help for final touch up to my code
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
|