Help on Existing Macro

S

shansakhi

Active Member
Joined
Apr 5, 2008
Messages
276
Office Version
  1. 365
Platform
  1. Windows
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
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
You must log in or register to reply here.

Similar threads

I
  • Solved
Set value for range being copied over with VBA
2
Replies
14
Views
280
ItalianPlatinum
I
C
  • Question
A Bookmark to return to the same row when exiting and opening the application
Replies
8
Views
199
Edgar_
Edgar_
S
  • Question
VBA Code - Create Log sheet (Errorlog) in case VBA Macro condition is not met
Replies
1
Views
186
Tupe77
T
N
  • Question
My code is suddenly really slow
Replies
1
Views
168
RobP
R
E
  • Solved
Copying data from 1 sheet to another in vba
Replies
7
Views
228
Kaper
Kaper

Forum statistics

Threads
1,215,798
Messages
6,126,974
Members
449,351
Latest member
Sylvine

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top