PDA

View Full Version : Help on existing macro



shan
11-30-2015, 04:05 AM
Hello Everybody,

I have written below two macro , but while running they are taking a long time.

Can you assist me with a way so it will take a less time.

Macro 1



Application.DisplayAlerts = False
On Error Resume Next
Sheets("Data").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Sheets.Add().Name = "Data"




Sheets("Base").Select
Cells.Select
Range("B1").Activate
Selection.Copy
Sheets("Data").Paste



Dim lastrow As Long


Sheets("Data").Select


Cells.Select
Selection.EntireColumn.Hidden = False


Cells.Select
Range("A1").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False



ActiveSheet.UsedRange.AutoFilter Field:=8, Criteria1:=RGB(255, _
255, 0), Operator:=xlFilterCellColor

Application.DisplayAlerts = False
ActiveSheet.UsedRange.Offset(1, 0).Resize(ActiveSheet.UsedRange.Rows.Count - 1).Rows.Delete
Application.DisplayAlerts = True


ActiveSheet.ShowAllData


ActiveWindow.FreezePanes = False


Columns("A:A").Delete


Range("A1:K14").UnMerge


Range("E12").Value = "RT1"


Range("F12").Value = "OW1"


Rows("13:14").Delete


Columns("A:A").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False


Columns("A:A").Select
Selection.Replace What:="/", Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False


Range("A:B").EntireColumn.Insert


Range("A12").Value = "Curr"


Range("B12").Value = "Orig"


Range("A13").FormulaR1C1 = "=R[-5]C[3]"
Range("B13").FormulaR1C1 = "=RIGHT(R[-12]C[1],3)"


Range("A13:B13").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Rows("1:11").Delete

Columns("C:C").UnMerge

lastrow = Range("D" & Rows.Count).End(xlUp).Row
Range("A2:A" & lastrow).Select


Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"

lastrow = Range("D" & Rows.Count).End(xlUp).Row
Range("B2:B" & lastrow).Select


Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"


lastrow = Range("D" & Rows.Count).End(xlUp).Row
Range("C2:C" & lastrow).Select


Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"


Columns("A:C").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

LR = Cells(Rows.Count, "C").End(xlUp).Row
For rw = LR To 2 Step -1
x = Split(Cells(rw, 3))
If UBound(x) > 0 Then
Rows(rw + 1).Resize(UBound(x)).Insert
Cells(rw, 1).Resize(, 8).Copy Cells(rw, 1).Resize(UBound(x) + 1, 8)
Cells(rw, 3).Resize(UBound(x) + 1) = Application.Transpose(x)
Else
x = Split(Cells(rw, 4))
If UBound(x) > 0 Then
Rows(rw + 1).Resize(UBound(x)).Insert
Cells(rw, 1).Resize(, 8).Copy Cells(rw, 1).Resize(UBound(x) + 1, 8)
Cells(rw, 4).Resize(UBound(x) + 1) = Application.Transpose(x)
End If
End If
Next rw




Range("I:J").EntireColumn.Insert
Range("I1").Value = "RT"
Range("J1").Value = "OO"


Range("I1:J1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

lastrow = Range("F" & Rows.Count).End(xlUp).Row
Range("I2:I" & lastrow).Select


Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"


lastrow = Range("F" & Rows.Count).End(xlUp).Row
Range("J2:J" & lastrow).Select


Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"


Columns("I:J").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False



Macro 2

Application.DisplayAlerts = False
On Error Resume Next
Sheets("Output").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Sheets.Add().Name = "Output"




Range("A1").Value = "#"
Range("B1").Value = "Status"
Range("C1").Value = "Cxr"
Range("D1").Value = "Action"
Range("E1").Value = "TarNo"
Range("F1").Value = "TarCd"
Range("G1").Value = "Global"
Range("H1").Value = "Orig"
Range("I1").Value = "Dest"
Range("J1").Value = "FareCls"
Range("K1").Value = "Bkg Cls"
Range("L1").Value = "Cabin"
Range("M1").Value = "OW/RT"
Range("N1").Value = "Ftnt"
Range("O1").Value = "RtgNo"
Range("P1").Value = "RuleNO"
Range("Q1").Value = "Curr"
Range("R1").Value = "Base Amt"
Range("S1").Value = "Amt Diff"
Range("T1").Value = "% Amt Diff"
Range("U1").Value = "YQYR Fuel"
Range("V1").Value = "Taxes"
Range("W1").Value = "TFC"
Range("X1").Value = "AIF"
Range("Y1").Value = "Travel Start"
Range("Z1").Value = "Travel End"
Range("AA1").Value = "Sale Start"
Range("AB1").Value = "Sale End"
Range("AC1").Value = "EffDt"
Range("AD1").Value = "Comment"
Range("AE1").Value = "Travel Complete"
Range("AF1").Value = "Travel Compl. Indicator"
Range("AG1").Value = "RateSheet Comment"




Sheets("Data").Select
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("B2:B" & lastrow).Copy
Sheets("Output").Range("H" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues


lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("C2:C" & lastrow).Copy
Sheets("Output").Range("I" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues


Sheets("Data").Select
Range("E2:E" & lastrow).Copy
Sheets("Output").Range("J" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues




Sheets("Data").Select
Range("I2:I" & lastrow).Copy
Sheets("Output").Range("M" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues




Sheets("Data").Select
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:A" & lastrow).Copy
Sheets("Output").Range("Q" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues


Sheets("Data").Select
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("G2:G" & lastrow).Copy
Sheets("Output").Range("R" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues


Sheets("Data").Select
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("B2:B" & lastrow).Copy
Sheets("Output").Range("H" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues


lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("C2:C" & lastrow).Copy
Sheets("Output").Range("I" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues


Sheets("Data").Select
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("F2:F" & lastrow).Copy
Sheets("Output").Range("J" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues


Sheets("Data").Select
Range("J2:J" & lastrow).Copy
Sheets("Output").Range("M" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues






Sheets("Data").Select
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("H2:H" & lastrow).Copy
Sheets("Output").Range("R" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues


Sheets("Data").Select
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:A" & lastrow).Copy
Sheets("Output").Range("Q" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues


Sheets("Output").Select
lastrow = Range("H" & Rows.Count).End(xlUp).Row
Range("B2:B" & lastrow).Value = "Pending"


lastrow = Range("H" & Rows.Count).End(xlUp).Row
Range("C2:C" & lastrow).Value = "SQ"


lastrow = Range("H" & Rows.Count).End(xlUp).Row
Range("D2:D" & lastrow).Value = "N"


lastrow = Range("J" & Rows.Count).End(xlUp).Row
Range("K2:K" & lastrow).Formula = "=left(RC[-1],1)"




With Range("A2:A" & Range("B" & Rows.Count).End(xlUp).Row)
.Cells(1, 1).Value = 1
.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
End With


Columns("K:K").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False


Range("A1").Select


Application.DisplayAlerts = False
Sheets("Data").Delete
Application.DisplayAlerts = True


Thank you in advance!!

Regards,
Shan

Paul_Hossler
11-30-2015, 07:39 AM
At a quick glance ...

1. You don't need to .Select something in order to act on it or use it

2. It appears that by using .Cells you are selecting and then copying every cell on the Sheet so I'm not surprised it's taking a long time. Read about .CurrentRegion or .UsedRange in help to only copy what needs to be copied




Sheets("Base").Select
Cells.Select
Range("B1").Activate
Selection.Copy
Sheets("Data").Paste

shan
11-30-2015, 07:56 AM
Thank you for your reply.. may i request you to make the changes in my macro so i can understand better.qq

Paul_Hossler
11-30-2015, 10:31 AM
I'll suggest one example, but without knowing the layout it's be too hard.

Also attached small example workbook




Option Explicit

Sub Macro1()

Application.DisplayAlerts = False
On Error Resume Next
Sheets("Data").Delete
Application.DisplayAlerts = True
On Error GoTo 0

Sheets.Add().Name = "Data"

MsgBox Sheets("Base").Range("B2").CurrentRegion.Address ' testing

Sheets("Base").Range("B2").CurrentRegion.Copy Sheets("Data").Range("B1")

End Sub

shan
11-30-2015, 09:10 PM
Thank you Paul..

I will make necessary changes to code and check..
Thanks