Results 1 to 10 of 10

Thread: Need your help to work this faster and doesnt freeze when running the code.

  1. #1

    Thread Starter
    Junior Member
    Join Date
    May 2017
    Posts
    20

    Need your help to work this faster and doesnt freeze when running the code.

    Code:
    Sub generate()
    
    Dim timeStart As Date, timeEnd As Date, dateDate As Date, dS As Date, dE As Date
    Dim lastRow As Long, erow As Integer, sheet1 As Worksheet, sheet2 As Worksheet
    Dim PSheet As Worksheet
    Dim DSheet As Worksheet
    Dim PCache As PivotCache
    Dim PTable As PivotTable
    Dim PRange As Range
    Dim LastCol As Long
    Dim Firstrow As Long
    Dim Lrow As Long
    Dim CalcMode As Long
    Dim ViewMode As Long
    Dim i As Long
    Dim r As Long, lr As Long
    Dim intA As Integer
        Dim wrksht As Excel.Worksheet
    Dim Aname As String
    'dim all variables
    timeStart = Now()
    
    
        Sheets("Episodes").Select
        Sheets("target").Visible = True
        Sheets("Episodes").Select
        Sheets("roster").Visible = True
    
        Set wrksht = Application.Worksheets("source")
        intA = 1
    
        Do Until intA = wrksht.UsedRange.Rows.Count
    
            Select Case wrksht.Cells(intA, "O").Value
                Case "OPEN", "OPEN - New", "OPEN-MD Review", "OPEN-PENDING", "OPEN-PENDING ACTIVITY", "OPEN-Transfer", "CLOSED BY ONSHORE", "VOID - INVALID-Rework"
                   wrksht.Rows(intA).Delete
    
                Case Else
                   intA = intA + 1
    
            End Select
    
        Loop
    
    
        Sheets("target").Select
        Cells.Select
        Selection.ClearContents
    
    Set sheet1 = Worksheets("source")
    Set sheet2 = Worksheets("target")
    lastRow = sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    
    For i = 1 To lastRow
        erow = sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 1).Row
        sheet2.Cells(erow, 1) = sheet1.Cells(i, 1) 'Episode_Number
        sheet2.Cells(erow, 2) = sheet1.Cells(i, 2) 'SR_Number
        sheet2.Cells(erow, 3) = sheet1.Cells(i, 4) 'CTS_DueDate
        sheet2.Cells(erow, 4) = sheet1.Cells(i, 6) 'Request_Received_Date
        sheet2.Cells(erow, 5) = sheet1.Cells(i, 7) 'FB_Age
        sheet2.Cells(erow, 6) = sheet1.Cells(i, 8) 'Group_Name
        sheet2.Cells(erow, 7) = sheet1.Cells(i, 9) 'Reason for Referral
        sheet2.Cells(erow, 8) = sheet1.Cells(i, 11) 'Client Group
        sheet2.Cells(erow, 9) = sheet1.Cells(i, 12) 'DueDate_Day
        sheet2.Cells(erow, 10) = sheet1.Cells(i, 13) 'Allocated To
        sheet2.Cells(erow, 11) = sheet1.Cells(i, 14) 'Allocated Date
        sheet2.Cells(erow, 12) = sheet1.Cells(i, 15) 'Status
        sheet2.Cells(erow, 13) = sheet1.Cells(i, 16) 'GBK Code
        sheet2.Cells(erow, 14) = sheet1.Cells(i, 18) 'Last Updated Date
        sheet2.Cells(erow, 15) = sheet1.Cells(i, 19) 'Uploaded Date
    
    Next i
    
        Columns("K:K").Select
        Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        Columns("J:J").Select
        Selection.TextToColumns Destination:=Range("J1"), DataType:=xlFixedWidth, _
            FieldInfo:=Array(Array(0, 1), Array(9, 1)), TrailingMinusNumbers:=True
        'Columns("K:K").Select
    
        Columns("J:J").Select
        Selection.Replace What:="-", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
    
        '-----
       ' inserts a new column and delimit
        Columns("M:M").Select
        Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        Columns("L:L").Select
        Selection.TextToColumns Destination:=Range("L1"), DataType:=xlFixedWidth, _
            FieldInfo:=Array(Array(0, 1), Array(11, 1)), TrailingMinusNumbers:=True
    
        ' converts to date
            Columns("L:L").Select
        Selection.TextToColumns Destination:=Range("L1"), DataType:=xlDelimited, _
            TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
            :=",", FieldInfo:=Array(1, 3), TrailingMinusNumbers:=True
    
          Columns("Q:Q").Select
        Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        Columns("P:P").Select
        Selection.TextToColumns Destination:=Range("P1"), DataType:=xlFixedWidth, _
            OtherChar:=",", FieldInfo:=Array(Array(0, 1), Array(12, 1)), _
            TrailingMinusNumbers:=True
        Selection.TextToColumns Destination:=Range("P1"), DataType:=xlDelimited, _
            TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
            :=",", FieldInfo:=Array(1, 3), TrailingMinusNumbers:=True
    
            Columns("R:R").Select
            Selection.TextToColumns Destination:=Range("R1"), DataType:=xlFixedWidth, _
            OtherChar:=",", FieldInfo:=Array(Array(0, 1), Array(12, 1)), _
            TrailingMinusNumbers:=True
            Selection.TextToColumns Destination:=Range("R1"), DataType:=xlDelimited, _
            TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=False, OtherChar _
            :=",", FieldInfo:=Array(1, 3), TrailingMinusNumbers:=True
    '
    '    '-------------------stop here
        'add headers
        Range("A1").Select
        ActiveCell.FormulaR1C1 = "Episode Number"
        Range("B1").Select
        ActiveCell.FormulaR1C1 = "SR Number"
        Range("C1").Select
        ActiveCell.FormulaR1C1 = "CTS Due Date"
        Range("D1").Select
        ActiveCell.FormulaR1C1 = "Request Received Data"
        Range("E1").Select
        ActiveCell.FormulaR1C1 = "FB Age"
        Range("F1").Select
        ActiveCell.FormulaR1C1 = "Group Name"
        Range("G1").Select
        ActiveCell.FormulaR1C1 = "Reason for Referral"
        Range("H1").Select
        ActiveCell.FormulaR1C1 = "Client Group"
        Range("I1").Select
        ActiveCell.FormulaR1C1 = "Due Date Day"
        Range("J1").Select
        ActiveCell.FormulaR1C1 = "Associate ID"
        Range("K1").Select
        ActiveCell.FormulaR1C1 = "Associates Name"
        Range("L1").Select
        ActiveCell.FormulaR1C1 = "Allocated Date"
        Range("M1").Select
        ActiveCell.FormulaR1C1 = "Aloocated Time"
        Range("N1").Select
        ActiveCell.FormulaR1C1 = "Status"
        Range("O1").Select
        ActiveCell.FormulaR1C1 = "GBK Code"
        Range("P1").Select
        ActiveCell.FormulaR1C1 = "Last Updated Date"
        Range("Q1").Select
        ActiveCell.FormulaR1C1 = "Total Work"
        Range("R1").Select
        ActiveCell.FormulaR1C1 = "Uploaded Date"
        Range("S1").Select
        ActiveCell.FormulaR1C1 = "Uploaded Time"
        Range("T1").Select
        ActiveCell.FormulaR1C1 = "Project Manager"
        Range("U1").Select
        ActiveCell.FormulaR1C1 = "Ops Manager"
        Range("V1").Select
        ActiveCell.FormulaR1C1 = "CLOSED-Overturned"
        Range("W1").Select
        ActiveCell.FormulaR1C1 = "CLOSED-Upheld"
        Range("X1").Select
        ActiveCell.FormulaR1C1 = "CLOSED-MD Approved"
        Range("Y1").Select
        ActiveCell.FormulaR1C1 = "VOID-Duplicate"
        Range("Z1").Select
        ActiveCell.FormulaR1C1 = "VOID-Already Paid"
        Range("AA1").Select
        ActiveCell.FormulaR1C1 = "VOID-Misroute"
        Range("AB1").Select
        ActiveCell.FormulaR1C1 = "VOID-Wrong Patient"
        Range("AC1").Select
        ActiveCell.FormulaR1C1 = "Productivity"
        '---- deletes the row 2 header
         Rows("2:2").Select
        Selection.Delete Shift:=xlUp
    '
    '    '----- stops here for vlookup associates and project manager
        Range("T2").Select
        ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-10],roster!C[-19]:C[-16],4,0)"
        Range("T2").Select
        Selection.AutoFill Destination:=Range("T2:T35000")
        Range("T2:T35000").Select
        Range("V4").Select
        '---- vlookup completed
        '--- paste values
    
        'computation here ---
        Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.NumberFormat = "0.00"
        Range("V2").Select
        ActiveCell.FormulaR1C1 = "=IF(RC[-8]=R1C,""1"",""0"")"
        Range("W2").Select
        ActiveCell.FormulaR1C1 = "=IF(RC[-9]=R1C,""1"",""0"")"
        Range("X2").Select
        ActiveCell.FormulaR1C1 = "=IF(RC[-10]=R1C,""1"",""0"")"
        Range("Y2").Select
        ActiveCell.FormulaR1C1 = "=IF(RC[-11]=R1C,"".25"",""0"")"
        Range("Z2").Select
        ActiveCell.FormulaR1C1 = "=IF(RC[-12]=R1C,"".25"",""0"")"
        Range("AA2").Select
        ActiveCell.FormulaR1C1 = "=IF(RC[-13]=R1C,"".25"",""0"")"
        Range("AB2").Select
        ActiveCell.FormulaR1C1 = "=IF(RC[-14]=R1C,"".25"",""0"")"
        Range("AC2").Select
        ActiveCell.FormulaR1C1 = "=SUM(RC[-7]:RC[-1])"
        Selection.NumberFormat = "0.00"
    
    
        'autofill to down
        Range("V2:AC2").Select
        Selection.AutoFill Destination:=Range("V2:AC35000")
        Selection.NumberFormat = "0.00"
        Range("V2:AC35000").Select
    
    
        Range("V2:AB2").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Application.CutCopyMode = False
        Selection.Copy
        Application.CutCopyMode = False
        Selection.Copy
        Range("V2").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    'Dim LastRow As Integer, erow As Integer, sheet1 As Worksheet, sheet2 As Worksheet
    'Delete Preivous Pivot Table Worksheet & Insert a New Blank Worksheet With Same Name
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Episodes").Delete
    Sheets.Add Before:=ActiveSheet
    ActiveSheet.Name = "Episodes"
    Application.DisplayAlerts = True
    Set PSheet = Worksheets("Episodes")
    Set DSheet = Worksheets("target")
    
    
    'Define Data Range
    lastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
    LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    Set PRange = DSheet.Cells(1, 1).Resize(lastRow, LastCol)
    
    'Define Pivot Cache
    Set PCache = ActiveWorkbook.PivotCaches.Create _
    (SourceType:=xlDatabase, SourceData:=PRange). _
    CreatePivotTable(TableDestination:=PSheet.Cells(2, 2), _
    TableName:="Episodes")
    
    
    'Insert Blank Pivot Table
    Set PTable = PCache.CreatePivotTable_
    '(TableDestination:=PSheet.Cells(1, 1), TableName:="SalesPivotTable")
    
    'Insert Row Fields -------------------------------------------
    
     ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
            "target!R1C1:R18000C21", Version:=xlPivotTableVersion15).CreatePivotTable _
            TableDestination:="Episodes!R3C1", TableName:="Episodes", DefaultVersion _
            :=xlPivotTableVersion15
        Sheets("Episodes").Select
        Cells(3, 1).Select
    
    
         With ActiveSheet.PivotTables("Episodes").PivotFields("Project Manager")
            .Orientation = xlRowField
            .Position = 1
        End With
        With ActiveSheet.PivotTables("Episodes").PivotFields("Associates Name")
            .Orientation = xlRowField
            .Position = 2
        End With
        ActiveSheet.PivotTables("Episodes").AddDataField ActiveSheet.PivotTables( _
            "Episodes").PivotFields("Total Work"), "Count of Total Work", xlCount
        With ActiveSheet.PivotTables("Episodes").PivotFields("Total Work")
            .Caption = "Total Work"
            .Function = xlCount
    
        End With
        ActiveSheet.PivotTables("Episodes").AddDataField ActiveSheet.PivotTables( _
            "Episodes").PivotFields("Productivity"), "Sum of Productivity", xlSum
        With ActiveSheet.PivotTables("Episodes").PivotFields("Productivity")
            .Caption = "Productivity"
            .Function = xlSum
        End With
    
        With ActiveSheet.PivotTables("Episodes").PivotFields("Status")
            .Orientation = xlRowField
            .Position = 3
        End With
        With ActiveSheet.PivotTables("Episodes").PivotFields("Last Updated Date")
            .Orientation = xlColumnField
            .Position = 1
        End With
    
        With ActiveSheet.PivotTables("Episodes").PivotFields("Client Group")
            .Orientation = xlPageField
            .Position = 1
        End With
        With ActiveSheet.PivotTables("Episodes").PivotFields("FB Age")
            .Orientation = xlPageField
            .Position = 1
        End With
        With ActiveSheet.PivotTables("Episodes").PivotFields("Group Name")
            .Orientation = xlPageField
            .Position = 1
        End With
        With ActiveSheet.PivotTables("Episodes").PivotFields("Reason for Referral")
            .Orientation = xlPageField
            .Position = 1
        End With
        With ActiveSheet.PivotTables("Episodes").PivotFields("GBK Code")
            .Orientation = xlPageField
            .Position = 1
        End With
        Range("B3").Select
        ActiveSheet.PivotTables("Episodes").CompactLayoutRowHeader = "Associates Name"
        Range("C3").Select
        ActiveSheet.PivotTables("Episodes").TableStyle2 = "PivotStyleDark7"
        Cells.Select
    
    
    
        With Selection.Font
            .Name = "Calibri"
            .Size = 10
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .ThemeColor = xlThemeColorLight1
            .TintAndShade = 0
            .ThemeFont = xlThemeFontNone
        End With
    
        ActiveWindow.DisplayGridlines = False
        Range("A4").Select
        ActiveSheet.PivotTables("Episodes").CompactLayoutRowHeader = _
            "Associates Name"
        Range("C3").Select
    
        ActiveWorkbook.ShowPivotTableFieldList = False
        Range("F5").Select
        ActiveWindow.FreezePanes = True
        ActiveWindow.Zoom = 85
        Cells.Select
    
    
    
    
        Sheets("target").Select
        ActiveWindow.SelectedSheets.Visible = False
        Sheets("roster").Select
        ActiveWindow.SelectedSheets.Visible = False
        Sheets("source").Select
        ActiveWindow.SelectedSheets.Visible = False
        'create a workbook
    'Episodes = ActiveWorkbook.Sheets(1).Range("A1").Value
    'Workbooks.Add
    'ActiveWorkbook.SaveAs Filename:=Episodes & ".xls"
    '
    '    Sheets("source").Select
    '    Application.CutCopyMode = False
    '    Selection.ClearContents
    '    Sheets("Episodes").Select
    '    Cells.EntireColumn.AutoFit
    
    timeEnd = Now()
    MsgBox ("Completed in " & Format(timeEnd - timeStart, "hh:mm:ss") & ".")
    
    
    End Sub
    ===

    hope to receive a response to you guys (experts). Appreciate your help on this.
    Last edited by si_the_geek; May 25th, 2017 at 07:26 AM. Reason: added Code tags

  2. #2
    Discovering Life Siddharth Rout's Avatar
    Join Date
    Feb 2005
    Location
    Mumbai, India
    Posts
    12,001

    Re: Need your help to work this faster and doesnt freeze when running the code.

    I just gave your code a quick glance. Here are few of my observations

    1. Avoid the use of .Select. Work with the object directly. See the below link

    Avoid using select

    Example

    Code:
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Episode Number"
    can be written as

    Code:
    Range("A1").Value = "Episode Number"
    2. Turn off events. For example

    Code:
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    '
    '~~> Your rest of the code
    '
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
    3. Avoid individually writing to cells. Your code

    Code:
    For i = 1 To lastRow
        erow = sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 1).Row
        sheet2.Cells(erow, 1) = Sheet1.Cells(i, 1) 'Episode_Number
        sheet2.Cells(erow, 2) = Sheet1.Cells(i, 2) 'SR_Number
        sheet2.Cells(erow, 3) = Sheet1.Cells(i, 4) 'CTS_DueDate
        sheet2.Cells(erow, 4) = Sheet1.Cells(i, 6) 'Request_Received_Date
        sheet2.Cells(erow, 5) = Sheet1.Cells(i, 7) 'FB_Age
        sheet2.Cells(erow, 6) = Sheet1.Cells(i, 8) 'Group_Name
        sheet2.Cells(erow, 7) = Sheet1.Cells(i, 9) 'Reason for Referral
        sheet2.Cells(erow, 8) = Sheet1.Cells(i, 11) 'Client Group
        sheet2.Cells(erow, 9) = Sheet1.Cells(i, 12) 'DueDate_Day
        sheet2.Cells(erow, 10) = Sheet1.Cells(i, 13) 'Allocated To
        sheet2.Cells(erow, 11) = Sheet1.Cells(i, 14) 'Allocated Date
        sheet2.Cells(erow, 12) = Sheet1.Cells(i, 15) 'Status
        sheet2.Cells(erow, 13) = Sheet1.Cells(i, 16) 'GBK Code
        sheet2.Cells(erow, 14) = Sheet1.Cells(i, 18) 'Last Updated Date
        sheet2.Cells(erow, 15) = Sheet1.Cells(i, 19) 'Uploaded Date
    Next i
    Can be written as

    Code:
    erow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 1).Row
    Sheet2.Range("A" & erow & ":O" & (erow + lastrow - 1)).Value = Sheet1.Range("A1:O" & lastrow).Value
    These are the few things that I noticed. Hope this helps...
    A good exercise for the Heart is to bend down and help another up...
    Please Mark your Thread "Resolved", if the query is solved


    MyGear:
    ★ CPU ★ Ryzen 5 5800X
    ★ GPU ★ NVIDIA GeForce RTX 3080 TI Founder Edition
    ★ RAM ★ G. Skill Trident Z RGB 32GB 3600MHz
    ★ MB ★ ASUS TUF GAMING X570 (WI-FI) ATX Gaming
    ★ Storage ★ SSD SB-ROCKET-1TB + SEAGATE 2TB Barracuda IHD
    ★ Cooling ★ NOCTUA NH-D15 CHROMAX BLACK 140mm + 10 of Noctua NF-F12 PWM
    ★ PSU ★ ANTEC HCG-1000-EXTREME 1000 Watt 80 Plus Gold Fully Modular PSU
    ★ Case ★ LIAN LI PC-O11 DYNAMIC XL ROG (BLACK) (G99.O11DXL-X)
    ★ Monitor ★ LG Ultragear 27" 240Hz Gaming Monitor
    ★ Keyboard ★ TVS Electronics Gold Keyboard
    ★ Mouse ★ Logitech G502 Hero

  3. #3
    Don't Panic! Ecniv's Avatar
    Join Date
    Nov 2000
    Location
    Amsterdam...
    Posts
    5,343

    Re: Need your help to work this faster and doesnt freeze when running the code.

    Take a look at DoEvents.

    It will slow the execution of the code depending on how many times you call it, but it hands the control back to windows, so windows doesnt think excel has stopped running.

    Usually use it with a variable holding a date time, and increase by 2 seconds ( now+cdate("00:00:02") ) each time its called, so as not to call too often...

    BOFH Now, BOFH Past, Information on duplicates

    Feeling like a fly on the inside of a closed window (Thunk!)
    If I post a lot, it is because I am bored at work! ;D Or stuck...
    * Anything I post can be only my opinion. Advice etc is up to you to persue...

  4. #4

    Thread Starter
    Junior Member
    Join Date
    May 2017
    Posts
    20

    Re: Need your help to work this faster and doesnt freeze when running the code.

    Quote Originally Posted by Siddharth Rout View Post
    I just gave your code a quick glance. Here are few of my observations

    1. Avoid the use of .Select. Work with the object directly. See the below link

    Avoid using select

    Example

    Code:
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Episode Number"
    can be written as

    Code:
    Range("A1").Value = "Episode Number"
    2. Turn off events. For example

    Code:
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    '
    '~~> Your rest of the code
    '
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
    3. Avoid individually writing to cells. Your code

    Code:
    For i = 1 To lastRow
        erow = sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 1).Row
        sheet2.Cells(erow, 1) = Sheet1.Cells(i, 1) 'Episode_Number
        sheet2.Cells(erow, 2) = Sheet1.Cells(i, 2) 'SR_Number
        sheet2.Cells(erow, 3) = Sheet1.Cells(i, 4) 'CTS_DueDate
        sheet2.Cells(erow, 4) = Sheet1.Cells(i, 6) 'Request_Received_Date
        sheet2.Cells(erow, 5) = Sheet1.Cells(i, 7) 'FB_Age
        sheet2.Cells(erow, 6) = Sheet1.Cells(i, 8) 'Group_Name
        sheet2.Cells(erow, 7) = Sheet1.Cells(i, 9) 'Reason for Referral
        sheet2.Cells(erow, 8) = Sheet1.Cells(i, 11) 'Client Group
        sheet2.Cells(erow, 9) = Sheet1.Cells(i, 12) 'DueDate_Day
        sheet2.Cells(erow, 10) = Sheet1.Cells(i, 13) 'Allocated To
        sheet2.Cells(erow, 11) = Sheet1.Cells(i, 14) 'Allocated Date
        sheet2.Cells(erow, 12) = Sheet1.Cells(i, 15) 'Status
        sheet2.Cells(erow, 13) = Sheet1.Cells(i, 16) 'GBK Code
        sheet2.Cells(erow, 14) = Sheet1.Cells(i, 18) 'Last Updated Date
        sheet2.Cells(erow, 15) = Sheet1.Cells(i, 19) 'Uploaded Date
    Next i
    Can be written as

    Code:
    erow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 1).Row
    Sheet2.Range("A" & erow & ":O" & (erow + lastrow - 1)).Value = Sheet1.Range("A1:O" & lastrow).Value
    These are the few things that I noticed. Hope this helps...
    === are you able to revise the whole code?

  5. #5
    Discovering Life Siddharth Rout's Avatar
    Join Date
    Feb 2005
    Location
    Mumbai, India
    Posts
    12,001

    Re: Need your help to work this faster and doesnt freeze when running the code.

    Quote Originally Posted by marcuz_jozef View Post
    === are you able to revise the whole code?
    I only give code in a platter if I am paid for it LMAO (Just Joking)

    I can but I want you to try it yourself. Else how will you learn mate?
    A good exercise for the Heart is to bend down and help another up...
    Please Mark your Thread "Resolved", if the query is solved


    MyGear:
    ★ CPU ★ Ryzen 5 5800X
    ★ GPU ★ NVIDIA GeForce RTX 3080 TI Founder Edition
    ★ RAM ★ G. Skill Trident Z RGB 32GB 3600MHz
    ★ MB ★ ASUS TUF GAMING X570 (WI-FI) ATX Gaming
    ★ Storage ★ SSD SB-ROCKET-1TB + SEAGATE 2TB Barracuda IHD
    ★ Cooling ★ NOCTUA NH-D15 CHROMAX BLACK 140mm + 10 of Noctua NF-F12 PWM
    ★ PSU ★ ANTEC HCG-1000-EXTREME 1000 Watt 80 Plus Gold Fully Modular PSU
    ★ Case ★ LIAN LI PC-O11 DYNAMIC XL ROG (BLACK) (G99.O11DXL-X)
    ★ Monitor ★ LG Ultragear 27" 240Hz Gaming Monitor
    ★ Keyboard ★ TVS Electronics Gold Keyboard
    ★ Mouse ★ Logitech G502 Hero

  6. #6

    Thread Starter
    Junior Member
    Join Date
    May 2017
    Posts
    20

    Re: Need your help to work this faster and doesnt freeze when running the code.

    Quote Originally Posted by Siddharth Rout View Post
    I only give code in a platter if I am paid for it LMAO (Just Joking)

    I can but I want you to try it yourself. Else how will you learn mate?
    -- got some error changingn the code you have metioned see below.

    Run time error 6


    For i = 1 To lastRow
    erow = sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 1).Row
    sheet2.Range("A" & erow & ":O" & (erow + lastRow - 1)).Value = sheet1.Range("A1:O" & lastRow).Value

  7. #7

    Thread Starter
    Junior Member
    Join Date
    May 2017
    Posts
    20

    Re: Need your help to work this faster and doesnt freeze when running the code.

    need your help here... to make this more accurate... like changing the format when done doing the paste values and convert it directly to values.

    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.NumberFormat = "0.00"
    Range("V2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-8]=R1C,""1"",""0"")"
    Range("W2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-9]=R1C,""1"",""0"")"
    Range("X2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-10]=R1C,""1"",""0"")"
    Range("Y2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-11]=R1C,"".25"",""0"")"
    Range("Z2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-12]=R1C,"".25"",""0"")"
    Range("AA2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-13]=R1C,"".25"",""0"")"
    Range("AB2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-14]=R1C,"".25"",""0"")"
    Range("AC2").Select
    ActiveCell.FormulaR1C1 = "=SUM(RC[-7]:RC[-1])"
    Selection.NumberFormat = "0.00"


    'autofill to down
    Range("V2:AC2").Select
    Selection.AutoFill Destination:=Range("V2:AC35000")
    Selection.NumberFormat = "0.00"
    Range("V2:AC35000").Select


    Range("V2:AB2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Application.CutCopyMode = False
    Selection.Copy
    Application.CutCopyMode = False
    Selection.Copy
    Range("V2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

  8. #8
    PowerPoster
    Join Date
    Dec 2004
    Posts
    25,618

    Re: Need your help to work this faster and doesnt freeze when running the code.

    Range("V2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-8]=R1C,""1"",""0"")"
    Range("W2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-9]=R1C,""1"",""0"")"
    Range("X2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-10]=R1C,""1"",""0"")"
    Range("Y2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-11]=R1C,"".25"",""0"")"
    Range("Z2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-12]=R1C,"".25"",""0"")"
    Range("AA2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-13]=R1C,"".25"",""0"")"
    Range("AB2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-14]=R1C,"".25"",""0"")"
    Range("AC2").Select
    ActiveCell.FormulaR1C1 = "=SUM(RC[-7]:RC[-1])"
    Selection.NumberFormat = "0.00"
    could be
    Code:
    with range("v2")
      .FormulaR1C1 = "=IF(RC[-8]=R1C,""1"",""0"")"
      .offset(, 1).FormulaR1C1 = "=IF(RC[-9]=R1C,""1"",""0"")"
      .offset(, 2).FormulaR1C1 = "=IF(RC[-10]=R1C,""1"",""0"")"
      .offset(, 3).FormulaR1C1 = "=IF(RC[-11]=R1C,"".25"",""0"")"
      .offset(, 4).FormulaR1C1 = "=IF(RC[-12]=R1C,"".25"",""0"")"
      .offset(, 5).FormulaR1C1 = "=IF(RC[-13]=R1C,"".25"",""0"")"
      .offset(, 6).FormulaR1C1 = "=IF(RC[-14]=R1C,"".25"",""0"")"
      .offset(, 7).FormulaR1C1 = "=SUM(RC[-7]:RC[-1])"
      .offset(, 7).numberformat = "0.00"
    end with
    Run time error 6

    For i = 1 To lastRow
    erow = sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 1).Row
    sheet2.Range("A" & erow & ":O" & (erow + lastRow - 1)).Value = sheet1.Range("A1:O" & lastRow).Value
    the code as siddharth posted no longer needs to be in a for i = 1 to lastrow loop
    i am not sure why you should get an overflow error with what that code does, unless the row returned by erow is greater than 65535, try changing erow to type long, though removing the loop may reduce the number of rows of data, to bring the row count down to an integer value
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

  9. #9

    Thread Starter
    Junior Member
    Join Date
    May 2017
    Posts
    20

    Re: Need your help to work this faster and doesnt freeze when running the code.

    here is the new code... hope you could still help me if i still have need to revise.

    Sub generate()

    Dim timeStart As Date, timeEnd As Date, dateDate As Date, dS As Date, dE As Date
    Dim lastRow As Long, erow As Integer, sheet1 As Worksheet, sheet2 As Worksheet
    Dim PSheet As Worksheet
    Dim DSheet As Worksheet
    Dim PCache As PivotCache
    Dim PTable As PivotTable
    Dim PRange As Range
    Dim LastCol As Long
    Dim Firstrow As Long
    Dim Lrow As Long
    Dim CalcMode As Long
    Dim ViewMode As Long
    Dim i As Long
    Dim r As Long, lr As Long
    Dim intA As Integer
    Dim wrksht As Excel.Worksheet
    Dim Aname As String
    'dim all variables
    timeStart = Now()


    Sheets("Episodes").Select
    Sheets("target").Visible = True
    Sheets("Episodes").Select
    Sheets("roster").Visible = True

    Set wrksht = Application.Worksheets("source")
    intA = 1

    Do Until intA = wrksht.UsedRange.Rows.Count

    Select Case wrksht.Cells(intA, "O").Value
    Case "OPEN", "OPEN - New", "OPEN-MD Review", "OPEN-PENDING", "OPEN-PENDING ACTIVITY", "OPEN-Transfer", "CLOSED BY ONSHORE", "VOID - INVALID-Rework"

    wrksht.Rows(intA).Delete

    Case Else
    intA = intA + 1

    End Select

    Loop


    Sheets("target").Select
    Cells.Select
    Selection.ClearContents

    Set sheet1 = Worksheets("source")
    Set sheet2 = Worksheets("target")
    lastRow = sheet1.Cells(Rows.Count, 1).End(xlUp).Row

    For i = 1 To lastRow
    erow = sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 1).Row
    'sheet2.Range("A" & erow & ":O" & (erow + lastRow - 1)).Value = sheet1.Range("A1:O" & lastRow).Value
    sheet2.Cells(erow, 1) = sheet1.Cells(i, 1) 'Episode_Number
    sheet2.Cells(erow, 2) = sheet1.Cells(i, 2) 'SR_Number
    sheet2.Cells(erow, 3) = sheet1.Cells(i, 4) 'CTS_DueDate
    sheet2.Cells(erow, 4) = sheet1.Cells(i, 6) 'Request_Received_Date
    sheet2.Cells(erow, 5) = sheet1.Cells(i, 7) 'FB_Age
    sheet2.Cells(erow, 6) = sheet1.Cells(i, 8) 'Group_Name
    sheet2.Cells(erow, 7) = sheet1.Cells(i, 9) 'Reason for Referral
    sheet2.Cells(erow, 8) = sheet1.Cells(i, 11) 'Client Group
    sheet2.Cells(erow, 9) = sheet1.Cells(i, 12) 'DueDate_Day
    sheet2.Cells(erow, 10) = sheet1.Cells(i, 13) 'Allocated To
    sheet2.Cells(erow, 11) = sheet1.Cells(i, 14) 'Allocated Date
    sheet2.Cells(erow, 12) = sheet1.Cells(i, 15) 'Status
    sheet2.Cells(erow, 13) = sheet1.Cells(i, 16) 'GBK Code
    sheet2.Cells(erow, 14) = sheet1.Cells(i, 18) 'Last Updated Date
    sheet2.Cells(erow, 15) = sheet1.Cells(i, 19) 'Uploaded Date

    Next i

    Columns("K:K").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("J:J").Select
    Selection.TextToColumns Destination:=Range("J1"), DataType:=xlFixedWidth, _
    FieldInfo:=Array(Array(0, 1), Array(9, 1)), TrailingMinusNumbers:=True
    'Columns("K:K").Select

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

    '-----
    ' inserts a new column and delimit
    Columns("M:M").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("L:L").Select
    Selection.TextToColumns Destination:=Range("L1"), DataType:=xlFixedWidth, _
    FieldInfo:=Array(Array(0, 1), Array(11, 1)), TrailingMinusNumbers:=True

    ' converts to date
    Columns("L:L").Select
    Selection.TextToColumns Destination:=Range("L1"), DataType:=xlDelimited, _
    TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :=",", FieldInfo:=Array(1, 3), TrailingMinusNumbers:=True

    Columns("Q:Q").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("P:P").Select
    Selection.TextToColumns Destination:=Range("P1"), DataType:=xlFixedWidth, _
    OtherChar:=",", FieldInfo:=Array(Array(0, 1), Array(12, 1)), _
    TrailingMinusNumbers:=True
    Selection.TextToColumns Destination:=Range("P1"), DataType:=xlDelimited, _
    TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :=",", FieldInfo:=Array(1, 3), TrailingMinusNumbers:=True

    Columns("R:R").Select
    Selection.TextToColumns Destination:=Range("R1"), DataType:=xlFixedWidth, _
    OtherChar:=",", FieldInfo:=Array(Array(0, 1), Array(12, 1)), _
    TrailingMinusNumbers:=True
    Selection.TextToColumns Destination:=Range("R1"), DataType:=xlDelimited, _
    TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, OtherChar _
    :=",", FieldInfo:=Array(1, 3), TrailingMinusNumbers:=True
    '
    ' '-------------------stop here
    'add headers
    Range("A1").Value = "Episode Number"
    Range("B1").Value = "SR Number"
    Range("C1").Value = "CTS Due Date"
    Range("D1").Value = "Request Received Data"
    Range("E1").Value = "FB Age"
    Range("F1").Value = "Group Name"
    Range("G1").Value = "Reason for Referral"
    Range("H1").Value = "Client Group"
    Range("I1").Value = "Due Date Day"
    Range("J1").Value = "Associate ID"
    Range("K1").Value = "Associates Name"
    Range("L1").Value = "Allocated Date"
    Range("M1").Value = "Allocated Time"
    Range("N1").Value = "Status"
    Range("O1").Value = "GBK Code"
    Range("P1").Value = "Last Updated Date"
    Range("Q1").Value = "Total Work"
    Range("R1").Value = "Uploaded Date"
    Range("S1").Value = "Uploaded Time"
    Range("T1").Value = "Project Manager"
    Range("U1").Value = "Ops Manager"
    Range("V1").Value = "CLOSED-Overturned"
    Range("W1").Value = "CLOSED-Upheld"
    Range("X1").Value = "CLOSED-MD Approved"
    Range("Y1").Value = "VOID-Duplicate"
    Range("Z1").Value = "VOID-Already Paid"
    Range("AA1").Value = "VOID-Misroute"
    Range("AB1").Value = "VOID-Wrong Patient"
    Range("AC1").Value = "Productivity"

    '---- deletes the row 2 header
    Rows("2:2").Select
    Selection.Delete Shift:=xlUp

    '
    ' '----- stops here for vlookup associates and project manager
    Range("T2").FormulaR1C1 = "=VLOOKUP(RC[-10],roster!C[-19]:C[-16],4,0)"
    Range("T2").Select
    Selection.AutoFill Destination:=Range("T2:T35000")
    '---- vlookup completed

    'computation here ---





    With Range("v2")
    .FormulaR1C1 = "=IF(RC[-8]=R1C,""1"",""0"")"
    .Offset(, 1).FormulaR1C1 = "=IF(RC[-9]=R1C,""1"",""0"")"
    .Offset(, 2).FormulaR1C1 = "=IF(RC[-10]=R1C,""1"",""0"")"
    .Offset(, 3).FormulaR1C1 = "=IF(RC[-11]=R1C,"".25"",""0"")"
    .Offset(, 4).FormulaR1C1 = "=IF(RC[-12]=R1C,"".25"",""0"")"
    .Offset(, 5).FormulaR1C1 = "=IF(RC[-13]=R1C,"".25"",""0"")"
    .Offset(, 6).FormulaR1C1 = "=IF(RC[-14]=R1C,"".25"",""0"")"
    .Offset(, 7).FormulaR1C1 = "=SUM(RC[-7]:RC[-1])"
    .Offset(, 7).NumberFormat = "0.00"

    End With
    'autofill to down

    Range("V2:AC2").AutoFill Destination:=Range("V2:AC35000")
    Range("V2:AC35000").NumberFormat = "0.00"
    Range("V2:AB2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Application.CutCopyMode = False
    Selection.Copy
    Application.CutCopyMode = False
    Selection.Copy
    Range("V2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    'Range("V2:AC2").AutoFill Destination:=Range("V2:AC35000")

    ' ActiveCell.FormulaR1C1 = "1"
    ' Range("V2:AB3").Select
    'delimit to convert to number
    Columns("V:V").Select
    Selection.TextToColumns Destination:=Range("V1"), DataType:=xlDelimited, _
    TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, OtherChar _
    :=",", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True

    Columns("W:W").Select
    Selection.TextToColumns Destination:=Range("W1"), DataType:=xlDelimited, _
    TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, OtherChar _
    :=",", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True

    Columns("X:X").Select
    Selection.TextToColumns Destination:=Range("X1"), DataType:=xlDelimited, _
    TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, OtherChar _
    :=",", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True

    Columns("Y:Y").Select
    Selection.TextToColumns Destination:=Range("Y1"), DataType:=xlDelimited, _
    TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, OtherChar _
    :=",", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True

    Columns("Z:Z").Select
    Selection.TextToColumns Destination:=Range("Z1"), DataType:=xlDelimited, _
    TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, OtherChar _
    :=",", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True

    Columns("AA:AA").Select
    Selection.TextToColumns Destination:=Range("AA1"), DataType:=xlDelimited, _
    TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, OtherChar _
    :=",", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True

    Columns("AB:AB").Select
    Selection.TextToColumns Destination:=Range("AB1"), DataType:=xlDelimited, _
    TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, OtherChar _
    :=",", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True

    Range("V2:AC35000").NumberFormat = "0.00"
    'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    'Dim LastRow As Integer, erow As Integer, sheet1 As Worksheet, sheet2 As Worksheet
    'Delete Preivous Pivot Table Worksheet & Insert a New Blank Worksheet With Same Name
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Episodes").Delete
    Sheets.Add Before:=ActiveSheet
    ActiveSheet.Name = "Episodes"
    Application.DisplayAlerts = True
    Set PSheet = Worksheets("Episodes")
    Set DSheet = Worksheets("target")


    'Define Data Range
    lastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
    LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    Set PRange = DSheet.Cells(1, 1).Resize(lastRow, LastCol)

    'Define Pivot Cache
    Set PCache = ActiveWorkbook.PivotCaches.Create _
    (SourceType:=xlDatabase, SourceData:=PRange). _
    CreatePivotTable(TableDestination:=PSheet.Cells(2, 2), _
    TableName:="Episodes")


    'Insert Blank Pivot Table
    Set PTable = PCache.CreatePivotTable_
    '(TableDestination:=PSheet.Cells(1, 1), TableName:="SalesPivotTable")

    'Insert Row Fields -------------------------------------------

    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
    "target!R1C1:R18000C21", Version:=xlPivotTableVersion15).CreatePivotTable _
    TableDestination:="Episodes!R3C1", TableName:="Episodes", DefaultVersion _
    :=xlPivotTableVersion15
    Sheets("Episodes").Select
    Cells(3, 1).Select


    With ActiveSheet.PivotTables("Episodes").PivotFields("Project Manager")
    .Orientation = xlRowField
    .Position = 1
    End With
    With ActiveSheet.PivotTables("Episodes").PivotFields("Associates Name")
    .Orientation = xlRowField
    .Position = 2
    End With
    ActiveSheet.PivotTables("Episodes").AddDataField ActiveSheet.PivotTables( _
    "Episodes").PivotFields("Total Work"), "Count of Total Work", xlCount
    With ActiveSheet.PivotTables("Episodes").PivotFields("Total Work")
    .Caption = "'Total Work"
    .Function = xlCount

    End With
    ActiveSheet.PivotTables("Episodes").AddDataField ActiveSheet.PivotTables( _
    "Episodes").PivotFields("Productivity"), "Sum of Productivity", xlSum
    With ActiveSheet.PivotTables("Episodes").PivotFields("Productivity")
    .Caption = "'Productivity"
    .Function = xlSum
    End With

    With ActiveSheet.PivotTables("Episodes").PivotFields("Status")
    .Orientation = xlRowField
    .Position = 3
    End With
    With ActiveSheet.PivotTables("Episodes").PivotFields("Last Updated Date")
    .Orientation = xlColumnField
    .Position = 1
    End With

    With ActiveSheet.PivotTables("Episodes").PivotFields("Client Group")
    .Orientation = xlPageField
    .Position = 1
    End With
    With ActiveSheet.PivotTables("Episodes").PivotFields("FB Age")
    .Orientation = xlPageField
    .Position = 1
    End With
    With ActiveSheet.PivotTables("Episodes").PivotFields("Group Name")
    .Orientation = xlPageField
    .Position = 1
    End With
    With ActiveSheet.PivotTables("Episodes").PivotFields("Reason for Referral")
    .Orientation = xlPageField
    .Position = 1
    End With
    With ActiveSheet.PivotTables("Episodes").PivotFields("GBK Code")
    .Orientation = xlPageField
    .Position = 1
    End With
    Range("B3").Select
    ActiveSheet.PivotTables("Episodes").CompactLayoutRowHeader = "Associates Name"
    Range("C3").Select
    ActiveSheet.PivotTables("Episodes").TableStyle2 = "PivotStyleDark7"
    Cells.Select



    With Selection.Font
    .Name = "Calibri"
    .Size = 10
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
    End With

    ActiveWindow.DisplayGridlines = False
    Range("A4").Select
    ActiveSheet.PivotTables("Episodes").CompactLayoutRowHeader = _
    "Associates Name"
    Range("C3").Select

    ActiveWorkbook.ShowPivotTableFieldList = False
    Range("F5").Select
    ActiveWindow.FreezePanes = True
    ActiveWindow.Zoom = 85
    Cells.Select




    Sheets("target").Select
    ActiveWindow.SelectedSheets.Visible = False
    Sheets("roster").Select
    ActiveWindow.SelectedSheets.Visible = False
    Sheets("source").Select
    ActiveWindow.SelectedSheets.Visible = False


    timeEnd = Now()
    MsgBox ("Completed in " & Format(timeEnd - timeStart, "hh:mm:ss") & ".")


    End Sub

  10. #10
    PowerPoster
    Join Date
    Dec 2004
    Posts
    25,618

    Re: Need your help to work this faster and doesnt freeze when running the code.

    USE code tags when posting code!!

    For i = 1 To lastRow
    erow = sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 1).Row
    it would be quicker to find erow 1 time only (before loop), then just add 1 to erow within loop
    Code:
    erow = erow + 1
    try to remove all instances of select, as per previous examples

    Code:
    'add headers
    Range("A1:AC1").Value = array("Episode Number", "SR Number", "CTS Due Date", "Request Received Data", "FB Age", "Group Name", "Reason ,for Referral", "Client Group", "Due Date Day", "Associate ID", "Associates Name", "Allocated Date", "Allocated Time", "Status", "GBK Code", Last Updated Date", "Total Work",  "Uploaded Date", "Uploaded Time", "Project Manager", "Ops Manager", "CLOSED-Overturned", "CLOSED-Upheld", "CLOSED-MD Approved", "VOID-Duplicate", "VOID-Already Paid", "VOID-Misroute", "VOID-Wrong Patient", "Productivity")
    the long list of the array can be broken into multiple lines

    Sheets("target").Select
    ActiveWindow.SelectedSheets.Visible = False
    Sheets("roster").Select
    ActiveWindow.SelectedSheets.Visible = False
    Sheets("source").Select
    ActiveWindow.SelectedSheets.Visible = False
    can be
    Code:
    Sheets("target").Visible = False
    Sheets("roster").Visible = False
    Sheets("source").Visible = False
    it is a bit hard just looking at a page full of unformatted code to see all the parts that can be improved, i have just picked bits and pieces as i have seen them
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

Posting Permissions

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



Click Here to Expand Forum to Full Width