test
Amazing chart utilities from Jon Peltier
Thanks Thanks:  0
Likes Likes:  0
Results 1 to 10 of 10

Thread: test

  1. #1
    New Member
    Join Date
    Feb 2018
    Location
    Florida
    Posts
    2
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default test

     
    Code:
    Sub DeleteRepeatHeadingsRow1()
      Dim lr As Long, lc As Long, i As Long, j As Long
      Dim a As Variant, b As Variant
     
      Application.ScreenUpdating = False
      lr = Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlValues, _
        SearchOrder:=xlByRows, SearchDirection:=xlPrevious, SearchFormat:=False).Row + 1
      lc = Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlValues, _
        SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, SearchFormat:=False).Column + 1
      a = Range("A1").Resize(lr, lc).Value
      ReDim b(1 To lr, 1 To 1)
      For i = 2 To lr
        j = 1
        Do While a(i, j) = a(1, j) And j < lc
          j = j + 1
        Loop
        If j < lc Then b(i, 1) = 1
      Next i
      With Range("A1").Resize(lr, lc)
        .Columns(lc).Value = b
        .Sort Key1:=.Columns(lc), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
          MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        .Columns(lc).Offset(1).SpecialCells(xlBlanks).EntireRow.Delete
        .Columns(lc).ClearContents
      End With
      Application.ScreenUpdating = True
    End Sub

  2. #2
    New Member
    Join Date
    Mar 2016
    Posts
    26
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: test

    Excel 2013/2016
    ABCDEFG
    1ABCL
    21S.3 $ 9.00
    32S.3 $ 5.00
    43S.4 $ 6.00
    54S.3
    65S.3
    762.11 $ 2.00
    87
    98

    Sheet1



    Worksheet Formulas
    CellFormula
    A1
    B1A
    C1B
    D1C
    E1
    F1
    G1L
    A21
    B2S.3
    C2
    D2
    E2
    F2
    G29
    A32
    B3S.3
    C3
    D3
    E3
    F3
    G35
    A43
    B4S.4
    C4
    D4
    E4
    F4
    G46
    A54
    B5S.3
    C5
    D5
    E5
    F5
    G5
    A65
    B6S.3
    C6
    D6
    E6
    F6
    G6
    A76
    B72.11
    C7
    D7
    E7
    F7
    G72
    A87
    B8
    C8
    D8
    E8
    F8
    G8
    A98
    B9
    C9
    D9
    E9
    F9
    G9


  3. #3
    New Member
    Join Date
    Mar 2016
    Posts
    26
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: test

    Excel 2013/2016
    ABCDEFG
    1ABCL
    21S.3 $ 9.00
    32S.3 $ 5.00
    43S.4 $ 6.00
    54S.3
    65S.3
    762.11 $ 2.00
    87
    98

    Sheet1



    Worksheet Formulas
    CellFormula
    A1
    B1A
    C1B
    D1C
    E1
    F1
    G1L
    A21
    B2S.3
    C2
    D2
    E2
    F2
    G29
    A32
    B3S.3
    C3
    D3
    E3
    F3
    G35
    A43
    B4S.4
    C4
    D4
    E4
    F4
    G46
    A54
    B5S.3
    C5
    D5
    E5
    F5
    G5
    A65
    B6S.3
    C6
    D6
    E6
    F6
    G6
    A76
    B72.11
    C7
    D7
    E7
    F7
    G72
    A87
    B8
    C8
    D8
    E8
    F8
    G8
    A98
    B9
    C9
    D9
    E9
    F9
    G9


  4. #4
    New Member
    Join Date
    Jul 2011
    Posts
    6
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: test

    Sub PrintPivotPages() 'prints a copy of pivot table for each item in page field 'assumes one page field exists Application.ScreenUpdating = False DirectoryLocation = ActiveWorkbook.Path On Error Resume Next Dim pt As PivotTable Dim pf As PivotField Dim pi As PivotItem Set pt = ActiveSheet.PivotTables.Item(1) For Each pf In pt.PageFields For Each pi In pf.PivotItems pt.PivotFields(pf.Name).CurrentPage = pi.Name Name = DirectoryLocation & "" & Range("B8").Value & ".pdf" ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=Name _ , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _ :=False, OpenAfterPublish:=False Next Next pf Application.ScreenUpdating = True End Sub


  5. #5
    New Member
    Join Date
    Jul 2011
    Posts
    6
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: test

    Code:
    Sub PrintPivotPages()
    'prints a copy of pivot table for each item in page field
    'assumes one page field exists
    Application.ScreenUpdating = False
    
    
    DirectoryLocation = ActiveWorkbook.Path
    
    
    On Error Resume Next
    Dim pt As PivotTable
    Dim pf As PivotField
    Dim pi As PivotItem
    Set pt = ActiveSheet.PivotTables.Item(1)
    For Each pf In pt.PageFields
    For Each pi In pf.PivotItems
            pt.PivotFields(pf.Name).CurrentPage = pi.Name
            
    
    
            Name = DirectoryLocation & "\" & Range("B8").Value & ".pdf"
            
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=Name _
            , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
            :=False, OpenAfterPublish:=False
            
    Next
    Next pf
    
    
    Application.ScreenUpdating = True
    
    
    End Sub

  6. #6
    New Member
    Join Date
    Jul 2015
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: test

    Excel 2016 (Windows) 32 bit
    A
    B
    C
    1
    CHAR LIST-A LIST-B
    2
    ABC TBA-001 TBD-001
    3
    ABC TBA-002 TBD-002
    4
    ABC TBA-003 TBD-003
    5
    ABC TBA-004 TBD-004
    6
    ABC TBA-005 TBD-005
    7
    DEF TBA-006 TBD-006
    8
    DEF TBA-007 TBD-007
    9
    DEF TBA-008 TBD-008
    10
    GHI TBA-009 TBD-009
    11
    GHI TBA-010 TBD-010
    Sheet: Sheet1

  7. #7
    New Member
    Join Date
    Feb 2018
    Posts
    7
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: test

    ABCDEFGHIJKLMNOPQRSTUVWX
    1Mon 12 FebTue 13 FebWed 14 FebThu 15 Feb
    2TimeSTAFF 1STAFF 2STAFF 3STAFF 4STAFF 5STAFF 6STAFF 1STAFF 2STAFF 3STAFF 4STAFF 5STAFF 6STAFF 1STAFF 2STAFF 3STAFF 4STAFF 5STAFF 6STAFF 1STAFF 2STAFF 3STAFF 4STAFF 5
    36.00SITE 1NOTWORKNOTWORK
    46.30SITE 1NOTWORKNOTWORK
    57.00SITE 1NOTWORKNOTWORK
    67.30SITE 1NOTWORKNOTWORK
    78.00TRAVELNOTWORKNOTWORK
    88.30SITE 2NOTWORKNOTWORK
    99.00SITE 2NOTWORKSITE 6
    109.30TRAVELNOTWORKSITE 6
    1110.00SITE 7NOTWORKSITE 6
    1210.30SITE 7NOTWORKTRAVEL
    1311.00SITE 7SITE 2SITE 5
    1411.30SITE 7SITE 2SITE 5
    1512.00SITE 7SITE 2SITE 5
    1612.30SITE 7SITE 2SITE 5
    1713.00TRAVELTRAVELBREAK
    1813.30BREAKBREAKTRAVEL
    1914.00PREPSITE 4PREP
    2014.30PREPSITE 4PREP
    2115.00SITE 5SITE 4PREP
    2215.30SITE 5SITE 4PREP
    2316.00NOTWORKSITE 4SITE 3
    2416.30NOTWORKSITE 4SITE 3
    2517.00NOTWORKTRAVELNOTWORK
    2617.30NOTWORKTRAVELNOTWORK
    2718.00NOTWORKSITE 5NOTWORK
    2818.30NOTWORKSITE 5NOTWORK
    2919.00NOTWORKSITE 5NOTWORK
    3019.30NOTWORKSITE 5NOTWORK
    3120.00NOTWORKTRAVELNOTWORK
    3220.30NOTWORKSITE 3NOTWORK
    3321.00NOTWORKSITE 3NOTWORK
    3421.30NOTWORKNOTWORKNOTWORK

    Sheet1




  8. #8
    New Member
    Join Date
    Feb 2018
    Posts
    7
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: test

    Code:
      Sub dates()
          Dim i As Long
          Dim lc As Long
          Dim dstart As Date, dend As Date
        
          ActiveSheet.Cells.EntireColumn.Hidden = False
       
          Application.ScreenUpdating = False
          lc = Cells(2, Columns.Count).End(xlToLeft).Column
          dstart = InputBox("Enter a start date, dd/mm/yyyy")
          dend = InputBox("Enter an end date, dd/mm/yyyy")
           ' Hide Selected Columns
          For i = 2 To lc
              If Cells(2, i) >= dstart And Cells(2, i) <= dend Then
                  Cells(2, i).EntireColumn.Hidden = False
              Else
                  Cells(2, i).EntireColumn.Hidden = True
              End If
          Next i
          Application.ScreenUpdating = True
      End Sub

  9. #9
    New Member
    Join Date
    Feb 2018
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

  10. #10
    New Member
    Join Date
    Feb 2018
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: test

      
    file:///C:/Users/tclinken/Desktop/CELLPROBLEM.PNG

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

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

 

 
DMCA.com