trying my luck here-VBForums
Results 1 to 2 of 2

Thread: trying my luck here

  1. #1

    Thread Starter
    New Member
    Join Date
    May 2017
    Posts
    11

    trying my luck here

    Can anyone help me on my code below to simplify... im not a programmer but i just tried to google everything and record some steps. But if you could help me simply the code below would be very much appreciated.

    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
    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 = "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:T30000")
    Range("T2:T30000").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 = "=SUM(RC[-6]:RC[-1])"
    Selection.NumberFormat = "0.00"


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


    Range("V2:AA2").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("Sum of Total Work")
    ' .Caption = "Count of Total Work"
    ' .Function = xlCount
    ' End With
    '\\\\
    With ActiveSheet.PivotTables("Episodes").PivotFields("Sum of Total Work")
    .Caption = "Count of Total Work"
    .Function = xlCount
    End With


    ActiveSheet.PivotTables("Episodes").AddDataField ActiveSheet.PivotTables( _
    "Episodes").PivotFields("Productivity"), "Count of Productivity", xlCount
    With ActiveSheet.PivotTables("Episodes").PivotFields("Count of 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("source").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Sheets("Episodes").Select
    Cells.EntireColumn.AutoFit

    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"


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


    End Sub

  2. #2

    Thread Starter
    New Member
    Join Date
    May 2017
    Posts
    11

    Re: trying my luck here

    Quote Originally Posted by marcuz_jozef View Post
    can anyone help me on my code below to simplify... Im not a programmer but i just tried to google everything and record some steps. But if you could help me simply the code below would be very much appreciated.

    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
    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").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 = "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:t30000")
    range("t2:t30000").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 = "=sum(rc[-6]:rc[-1])"
    selection.numberformat = "0.00"


    'autofill to down
    range("v2:ab2").select
    selection.autofill destination:=range("v2:ab15000")
    selection.numberformat = "0.00"
    range("v2:ab15000").select


    range("v2:aa2").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("sum of total work")
    ' .caption = "count of total work"
    ' .function = xlcount
    ' end with
    '\\\\
    with activesheet.pivottables("episodes").pivotfields("sum of total work")
    .caption = "count of total work"
    .function = xlcount
    end with


    activesheet.pivottables("episodes").adddatafield activesheet.pivottables( _
    "episodes").pivotfields("productivity"), "count of productivity", xlcount
    with activesheet.pivottables("episodes").pivotfields("count of 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("source").select
    application.cutcopymode = false
    selection.clearcontents
    sheets("episodes").select
    cells.entirecolumn.autofit

    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"


    timeend = now()
    msgbox ("completed in " & format(timeend - timestart, "hh:mm:ss") & ".")


    end sub
    =====help please=====

Posting Permissions

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



Featured


Click Here to Expand Forum to Full Width

Survey posted by VBForums.