Sub CreatePivotTable()
'activated by Ctrl + t as defined in Workbook_Open()

Dim rData As Range
Dim pcNew As PivotCache
Dim rCell As Range
Dim iFieldCnt As Long
Dim ptNew As PivotTable
Dim sShName As String
Dim sShNameOrig As String
Dim pf As PivotField
Dim i As Long
Dim ws As Worksheet

Const sField = "Field"
iFieldCnt = 1

ActiveSheet.UsedRange

'make sure a range is selected
If TypeName(Selection) = "Range" Then
    'if a single row is selected, set range to Current Region
    If Selection.Rows.Count = 1 Then
        Set rData = ActiveCell.CurrentRegion
    Else
        Set rData = Intersect(Selection, ActiveSheet.UsedRange)
    End If
    
    'put column headers in blank cells
    For Each rCell In rData.Rows(1).Cells
        If IsEmpty(rCell.Value) Then
            rCell.Value = sField & iFieldCnt
            iFieldCnt = iFieldCnt + 1
        End If
    Next rCell
    
    'set new sheet name to source name & Pivot
    sShNameOrig = ActiveSheet.Name
    sShName = ActiveSheet.Name
    
    If Len(sShName) > 25 Then
        sShName = Left(sShName, 25) & " Pivot"
    Else: sShName = sShName & " Pivot"
    End If

    'add new sheet to the right of source
    Set ws = Sheets.Add(After:=Sheets(sShNameOrig), Type:="Worksheet")
    ws.Name = sShName
    
    'create and set default Pivot Table Style to custom style
    'Call PivotTableStyle
    
    Set pcNew = ActiveWorkbook.PivotCaches.Create(xlDatabase, rData)
    Set ptNew = pcNew.CreatePivotTable(ws.Range("A3"))
    
    'set layout to Classic
    With ptNew
        .InGridDropZones = True
        .RowAxisLayout xlTabularRow
        .ColumnGrand = True
        .RowGrand = False
        '.RepeatAllLabels xlRepeatLabels
        .ShowTableStyleRowHeaders = False
        .ShowDrillIndicators = False
        .HasAutoFormat = True
        .SaveData = True
        .ManualUpdate = True
    End With
    
    ws.Range("A3").Select
    
End If

End Sub

Only registered members can see post attachments!

schmagekie fucked around with this message at 09:21 on Jun 15, 2014

Sub AlignLeft()
    Dim oRng As Range
    Dim jCol As Long
      
On Error GoTo ErrorHandler

    Set oRng = Intersect(Selection, ActiveSheet.UsedRange)

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    On Error Resume Next
    
    For jCol = 1 To oRng.Columns.Count
        oRng.Columns(1).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
    Next jCol
    
    On Error GoTo 0
        
ErrorExit:
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
    
Exit Sub
    
ErrorHandler:
    MsgBox Err.Description, vbCritical
Resume ErrorExit

End Sub

Sub DeleteBlanksInColB()
    Dim oRng As Range
    Dim jRows As Long
    Dim nCounter As Long
    
On Error GoTo ErrorHandler

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    Set oRng = Intersect(ActiveSheet.Range("B:B"), ActiveSheet.UsedRange)
    
    jRows = oRng.Rows.Count

    For nCounter = jRows To 1 Step -1
        If Cells(nCounter, 2).Value2 = 0 Then
            Cells(nCounter, 2).EntireRow.Delete
        End If
    Next nCounter
    
ErrorExit:
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
    
Exit Sub
    
ErrorHandler:
    MsgBox Err.Description, vbCritical
Resume ErrorExit

End Sub

schmagekie fucked around with this message at 06:48 on Jul 11, 2014

schmagekie fucked around with this message at 19:25 on Sep 16, 2014

schmagekie fucked around with this message at 21:23 on Sep 16, 2014

schmagekie fucked around with this message at 16:41 on Sep 23, 2014

schmagekie fucked around with this message at 20:11 on Oct 16, 2015

Sub GetData()
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim wksIndex As Worksheet
    Dim RowCount As Long

    RowCount = 4
    Set wkb = ActiveWorkbook
    Set wksIndex = wkb.Sheets("Index")

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ClearData
    SetDate

    'take H4:M7 from each sheet and put it on the index sheet
    For Each wks In wkb.Sheets
        If wks.Name <> "Index" And wks.Name <> "LastSheetName" Then 'change LastSheetName to its actual name
            wksIndex.Range(Cells(RowCount, 2), Cells(RowCount + 3, 7)).Value2 = wks.Range("H4:M7").Value2
            RowCount = RowCount + 6
        End If
    Next wks

    wksIndex.Cells(RowCount, 4) = "Total:"
    wksIndex.Cells(RowCount, 5) = Application.Sum(Range(Cells(1, 5), Cells(RowCount, 5)))

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

schmagekie fucked around with this message at 19:28 on Mar 15, 2016