-
May 25th, 2017, 05:54 AM
#1
Thread Starter
Junior Member
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
-
May 25th, 2017, 10:05 AM
#2
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
-
May 25th, 2017, 03:44 PM
#3
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...
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...
-
May 26th, 2017, 03:08 AM
#4
Thread Starter
Junior Member
Re: Need your help to work this faster and doesnt freeze when running the code.
Originally Posted by Siddharth Rout
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?
-
May 26th, 2017, 03:20 AM
#5
Re: Need your help to work this faster and doesnt freeze when running the code.
Originally Posted by marcuz_jozef
=== 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
-
May 30th, 2017, 07:20 AM
#6
Thread Starter
Junior Member
Re: Need your help to work this faster and doesnt freeze when running the code.
Originally Posted by Siddharth Rout
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
-
May 30th, 2017, 07:21 AM
#7
Thread Starter
Junior Member
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
-
May 31st, 2017, 03:42 AM
#8
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
-
May 31st, 2017, 07:37 AM
#9
Thread Starter
Junior Member
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
-
May 31st, 2017, 04:26 PM
#10
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
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
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|