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