Consulting

Results 1 to 5 of 5

Thread: Help on existing macro

  1. 11-30-2015, 04:05 AM #1
    shan
    shan is offline
    VBAX Regular
    Joined
    Jun 2015
    Posts
    88
    Location

    Help on existing macro

    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
    Last edited by SamT; 11-30-2015 at 05:35 AM.
    Reply With Quote Reply With Quote
  2. 11-30-2015, 07:39 AM #2
    Paul_Hossler
    Paul_Hossler is offline
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,729
    Location
    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
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3
    Reply With Quote Reply With Quote
  3. 11-30-2015, 07:56 AM #3
    shan
    shan is offline
    VBAX Regular
    Joined
    Jun 2015
    Posts
    88
    Location
    Thank you for your reply.. may i request you to make the changes in my macro so i can understand better.qq
    Reply With Quote Reply With Quote
  4. 11-30-2015, 10:31 AM #4
    Paul_Hossler
    Paul_Hossler is offline
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,729
    Location
    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
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3
    Reply With Quote Reply With Quote
  5. 11-30-2015, 09:10 PM #5
    shan
    shan is offline
    VBAX Regular
    Joined
    Jun 2015
    Posts
    88
    Location
    Thank you Paul..

    I will make necessary changes to code and check..
    Thanks
    Reply With Quote Reply With Quote
« Previous Thread | Next Thread »

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  

Forum Rules